MODULE drv_input_mod USE netcdf USE drv_dat_mod CONTAINS SUBROUTINE drv_readcon(unit) !====================================================================== ! Description: This routine reads the run control deck, which contains all ! of the run-specific parameters, file paths, etc. that are ! controlled from outside the model. Ideally, the run control ! deck is the ONLY file that would need to be changed to run ! LSS for different offline experiments, either 0D, 1D or 2D. ! Concept: Liberally "borrowed" from Paul Houser's driver for CLM, and the ! overall NASA LDAS driver philosophy. ! Dec 2001 P. Dirmeyer ! $Log: drv_readcon.f90,v $ ! Revision 1.1 2002/09/17 17:13:57 guo ! Initial revision ! !====================================================================== !** Declare Modules and data structures IMPLICIT NONE !=== Local Variables ===================================================== CHARACTER(len=12) :: VName ! variable name read from run.con CHARACTER(len=60) :: cwork ! for making droot right justified INTEGER :: unit ! Fortran unit number INTEGER :: IOVAL ! Read error code INTEGER :: leng ! Length of string for 'droot' IOVAL = 0 ncin_count = 0 DO WHILE (IOVAL == 0) VName = '!' READ(unit,'(A12)',IOSTAT=IOVAL) VName IF (VNAME == 'fopen') THEN CALL openfile(unit) ENDIF IF (VName == 'ncin_file') THEN ncin_count = ncin_count + 1 CALL getcvar(unit,ncin_file(ncin_count),128) ENDIF IF (VName == 'mout_file') CALL getcvar(unit,mout_file,128) IF (VName == 'fout_file') CALL getcvar(unit,fout_file,128) IF (VName == 'gout_file') CALL getcvar(unit,gout_file,128) IF (VName == 'lpnts') CALL getivar(unit,lpnts) IF (VName == 'lonin') CALL getivar(unit,lonin) IF (VName == 'latin') CALL getivar(unit,latin) IF (VName == 'dtt') CALL getrvar(unit,dtt) IF (VName == 'adtt') CALL getrvar(unit,adtt) IF (VName == 'nodsecin') CALL getrvar(unit,nodsecin) IF (VName == 'title') CALL getcvar(unit,title,48) IF (VName == 'user') CALL getcvar(unit,user,32) IF (VName == 'iyrst') CALL getivar(unit,iyrst) IF (VName == 'mthst') CALL getivar(unit,mthst) IF (VName == 'ndyst') CALL getivar(unit,ndyst) IF (VName == 'nhrst') CALL getivar(unit,nhrst) IF (VName == 'iyrend') CALL getivar(unit,iyrend) IF (VName == 'mthend') CALL getivar(unit,mthend) IF (VName == 'ndyend') CALL getivar(unit,ndyend) IF (VName == 'nhrend') CALL getivar(unit,nhrend) IF (VName == 'iyrbeg') CALL getivar(unit,iyrbeg) IF (VName == 'mthbeg') CALL getivar(unit,mthbeg) IF (VName == 'ndybeg') CALL getivar(unit,ndybeg) IF (VName == 'nhrbeg') CALL getivar(unit,nhrbeg) IF (VName == 'iyrfin') CALL getivar(unit,iyrfin) IF (VName == 'mthfin') CALL getivar(unit,mthfin) IF (VName == 'ndyfin') CALL getivar(unit,ndyfin) IF (VName == 'nhrfin') CALL getivar(unit,nhrfin) ENDDO END SUBROUTINE drv_readcon SUBROUTINE getivar(unit,drvvar) !========================================================================= ! getivar.f: ! ! DESCRIPTION: ! The following subroutine simply reads integer data from control deck ! into the appropriate driver variable ! ! REVISION HISTORY: ! 6 May 1999: Paul Houser; initial code for CLM driver ! Dec 2001 : P. Dirmeyer; LSS driver application !========================================================================= IMPLICIT NONE INTEGER :: unit CHARACTER(len=12) :: VName INTEGER :: drvvar INTEGER :: ivar BACKSPACE(unit) READ(unit,*)VName,ivar drvvar = ivar write(6,*)VName,drvvar END SUBROUTINE getivar SUBROUTINE getrvar(unit,drvvar) !========================================================================= ! getrvar.f: ! ! DESCRIPTION: ! The following subroutine simply reads real data from control deck ! into the appropriate driver variable ! ! REVISION HISTORY: ! 6 May 1999: Paul Houser; initial code for CLM driver ! Dec 2001 : P. Dirmeyer; LSS driver application !========================================================================= IMPLICIT NONE INTEGER :: unit CHARACTER(len=12) :: VName REAL :: drvvar REAL :: ivar BACKSPACE(unit) READ(unit,*)VName,ivar drvvar = ivar write(6,*)VName,drvvar END SUBROUTINE getrvar SUBROUTINE getcvar(unit,drvvar,leng) !========================================================================= ! getcvar.f: ! ! DESCRIPTION: ! The following subroutine simply reads character data from control deck ! into the appropriate driver variable ! ! REVISION HISTORY: ! 6 May 1999: Paul Houser; initial code for CLM driver ! Dec 2001 : P. Dirmeyer; LSS driver application !========================================================================= IMPLICIT NONE INTEGER :: unit INTEGER :: leng CHARACTER(len=12) :: VName CHARACTER(len=leng) :: drvvar BACKSPACE(unit) READ(unit,*)VName,drvvar write(6,*)VName,drvvar(1:len_trim(drvvar)) END SUBROUTINE getcvar SUBROUTINE openfile(unit) !========================================================================= ! openfile.f: ! ! DESCRIPTION: ! The following subroutine simply reads the fle information, and open ! ther file. !========================================================================= IMPLICIT NONE INTEGER :: unit INTEGER :: funit INTEGER :: irec INTEGER :: iostat CHARACTER(len=12) :: VName CHARACTER(len=55) :: name CHARACTER(len=11) :: form CHARACTER(len=7) :: unknow= 'UNKNOWN' CHARACTER(len=6) :: access CHARACTER(len=1) :: ro funit= 99999 name(1:1)= ' ' form(1:1)= ' ' access(1:1) =' ' irec=0 BACKSPACE(unit) READ(unit,9000,IOSTAT=iostat) VName,funit,ro,name,form,access,irec IF(iostat < 0) STOP 9000 FORMAT (A12,1X,I2,A1,1X,A55,1X,A11,1X,A6,1X,I6) IF(funit == 99999 .OR. name(1:1) == ' ')THEN WRITE (6,*) 'Openfile error: invalid record in file' STOP ENDIF WRITE(6,9000) VName,funit,ro,name,form,access,irec IF(ro == ' ')THEN IF(access(1:1) /= ' ')THEN IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,ACCESS=access,RECL=irec) ELSE OPEN(funit,NAME=name,STATUS=unknow,ACCESS=access,RECL=irec) ENDIF ELSE IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form) ELSE OPEN(funit,NAME=name,STATUS=unknow) ENDIF ENDIF ELSE IF(ro == 'R')THEN IF(access(1:1) /= ' ')THEN IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,ACCESS=access, & RECL=irec,READONLY,SHARED) ELSE OPEN(funit,NAME=name,STATUS=unknow,ACCESS=access,RECL=irec, & READONLY,SHARED) ENDIF ELSE IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,READONLY,SHARED) ELSE OPEN(funit,NAME=name,STATUS=unknow,READONLY,SHARED) ENDIF ENDIF !ELSE IF(ro /= 'B')THEN ELSE IF(ro == 'B')THEN IF(access(1:1) /= ' ')THEN IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,ACCESS=access, & RECL=irec,RECORDTYPE='STREAM',CONVERT='BIG_ENDIAN', & READONLY,SHARED) ELSE OPEN(funit,NAME=name,STATUS=unknow,ACCESS=access,RECL=irec, & READONLY,SHARED,RECORDTYPE='STREAM',CONVERT='BIG_ENDIAN') ENDIF ELSE IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,READONLY,SHARED, & RECORDTYPE='STREAM',CONVERT='BIG_ENDIAN') ELSE OPEN(funit,NAME=name,STATUS=unknow,READONLY,SHARED, & RECORDTYPE='STREAM',CONVERT='BIG_ENDIAN') ENDIF ENDIF ELSE IF(ro == 'b')THEN IF(access(1:1) /= ' ')THEN IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,ACCESS=access, & RECL=irec,RECORDTYPE='STREAM',CONVERT='BIG_ENDIAN') ELSE OPEN(funit,NAME=name,STATUS=unknow,ACCESS=access,RECL=irec, & RECORDTYPE='STREAM',CONVERT='BIG_ENDIAN') ENDIF ELSE IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form, & RECORDTYPE='STREAM',CONVERT='BIG_ENDIAN') ELSE OPEN(funit,NAME=name,STATUS=unknow,RECORDTYPE='STREAM', & CONVERT='BIG_ENDIAN') ENDIF ENDIF ELSE IF(ro == 'E')THEN IF(access(1:1) /= ' ')THEN IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,ACCESS=access, & RECL=irec,CONVERT='BIG_ENDIAN',READONLY,SHARED) ELSE OPEN(funit,NAME=name,STATUS=unknow,ACCESS=access,RECL=irec, & READONLY,CONVERT='BIG_ENDIAN') ENDIF ELSE IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,READONLY,SHARED, & CONVERT='BIG_ENDIAN') ELSE OPEN(funit,NAME=name,STATUS=unknow,READONLY,SHARED, & CONVERT='BIG_ENDIAN') ENDIF ENDIF ELSE IF(ro == 'e')THEN IF(access(1:1) /= ' ')THEN IF(form(1:1) /=' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,ACCESS=access, & RECL=irec,CONVERT='BIG_ENDIAN') ELSE OPEN(funit,NAME=name,STATUS=unknow,ACCESS=access,RECL=irec, & CONVERT='BIG_ENDIAN') ENDIF ELSE IF(form(1:1) /= ' ')THEN OPEN(funit,NAME=name,STATUS=unknow,FORM=form,CONVERT='BIG_ENDIAN') ELSE OPEN(funit,NAME=name,STATUS=unknow,CONVERT='BIG_ENDIAN') ENDIF ENDIF ENDIF END SUBROUTINE openfile SUBROUTINE drv_almaparse(fnames,nb_files,ncv_dim,ncv_info,ncv_index) !====================================================================== ! Description: Quality check on netCDF files which wish to comply to the ! ALMA standard. alpha version : 25/09/00 from Jan Polcher ! (polcher@lmd.jussieu.fr) ! Revision: 1. Modified for use within LSS. P. Dirmeyer 8/2001 ! 2. Converted to be the primary means of opening and cataloging ! contents of NetCDF input files for the LSS driver P. Dirmeyer 8/2001 ! 3. Updated to NetCDF F90 interface. The current version of DODS ! cannot handle large data transfer, change check_force to "false" to ! skip quality check for some variables with DODS run. Z. Guo 8/2002 ! $Log: drv_almaparse.f90,v $ !====================================================================== ! IMPLICIT NONE ! ! Input variables INTEGER, INTENT(IN) :: nb_files ! Number of files CHARACTER(LEN=128), INTENT(IN) :: fnames(nb_files) ! List of files to parse INTEGER, INTENT(IN) :: ncv_dim ! Dim of ncv_ arrays ! ! In/out variables TYPE(nc_pointer), INTENT(INOUT) :: ncv_info(ncv_dim) ! Structure for NetCDF input info INTEGER, INTENT(INOUT) :: ncv_index ! Number of variables found ! ! Local variables INTEGER :: iread, ier LOGICAL :: check=.TRUE. ! INTEGER :: nbvar_max, nbvar CHARACTER(LEN=80), ALLOCATABLE :: var_names(:), var_units(:) CHARACTER(LEN=1), ALLOCATABLE :: var_sgnconv(:), var_level(:) LOGICAL, ALLOCATABLE :: var_found(:) CHARACTER(LEN=250) :: not_recognized CHARACTER(LEN=30) :: conv_str REAL, ALLOCATABLE :: var_max(:), var_min(:) LOGICAL :: sgn_traditional ! INTEGER :: ncid, iff INTEGER :: conf_unit=12 ! ! Default values ! nbvar_max = 200 ! ! Dont know how to do this in the subroutine nct_getarg, If you know ! please tell me ! (Jan) ! !PAD iread = iargc() iread = nb_files ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Get the configuration file ! We need to allocate the memory to keep this information !PAD >>> For forcing, assume just one file at a time here for now -PAD ! nbvar = 0 ! ALLOCATE (var_names(nbvar_max), stat=ier) IF (ier.NE.0) THEN WRITE (6,*) ' Could not allocate var_names of size ', nbvar_max STOP 'almaparse' END IF ! ALLOCATE (var_units(nbvar_max), stat=ier) IF (ier.NE.0) THEN WRITE (6,*) ' Could not allocate var_units of size ', nbvar_max STOP 'almaparse' END IF ! ALLOCATE (var_sgnconv(nbvar_max), stat=ier) IF (ier.NE.0) THEN WRITE (6,*) ' Could not allocate var_sgnconv of size ', nbvar_max STOP 'almaparse' END IF ! ALLOCATE (var_level(nbvar_max), stat=ier) IF (ier.NE.0) THEN WRITE (6,*) ' Could not allocate var_level of size ', nbvar_max STOP 'almaparse' END IF ! ALLOCATE (var_max(nbvar_max), stat=ier) IF (ier.NE.0) THEN WRITE (6,*) ' Could not allocate var_max of size ', nbvar_max STOP 'almaparse' END IF ! ALLOCATE (var_min(nbvar_max), stat=ier) IF (ier.NE.0) THEN WRITE (6,*) ' Could not allocate var_min of size ', nbvar_max STOP 'almaparse' END IF ! ALLOCATE (var_found(nbvar_max), stat=ier) IF (ier.NE.0) THEN WRITE (6,*) ' Could not allocate var_found of size ', nbvar_max STOP 'almaparse' END IF var_found(:) = .FALSE. ! ! CALL almaqc_getconf(conf_unit, nbvar_max, check, nbvar,& & var_names, var_units, var_sgnconv, var_level, var_max, var_min) PAUSE ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Go through all files and check if each variable is correct. ! DO iff = 1, nb_files ! ier = NF90_OPEN(fnames(iff), NF90_NOWRITE, ncid) WRITE (6,*) 'Opening ncid= ',ncid,': ',fnames(iff) ! IF ( ier .NE. NF90_NOERR ) THEN WRITE(6,*) 'Error while opening file ', fnames(iff) WRITE(6,*) NF90_STRERROR(ier) STOP ENDIF ! ! Get the attribute for the sign convention ! conv_str = ' ' ier = NF90_GET_ATT(ncid, NF90_GLOBAL, 'SurfSgn_convention', conv_str) ! IF ( ier .NE. NF90_NOERR ) THEN sgn_traditional = .TRUE. ELSE CALL strlowercase (conv_str) IF ( index(conv_str,'tradi') .GE. 1 ) THEN sgn_traditional = .TRUE. ELSE IF ( index(conv_str,'mathema') .GE. 1 ) THEN sgn_traditional = .FALSE. ELSE WRITE(6,*) 'Unknown sign convention, please check the netCDF file' STOP ENDIF ENDIF ! ! Inform the user of what we found for the sign convention ! IF ( sgn_traditional ) THEN WRITE(6,*) 'Using TRADITIONAL sign convention for the quality checks.' ELSE WRITE(6,*) 'Using the MATHEMATICAL sign convention for the quality checks.' ENDIF ! ! Now we go through the variables and do the work ! CALL almaqc_checkvar(ncid, nbvar, var_names, var_units, var_sgnconv, var_level, & & var_max, var_min, var_found, sgn_traditional, not_recognized, check, & & ncv_dim, ncv_info, ncv_index) ! CALL almaqc_bilan(iff, nb_files, fnames, nbvar, var_names, var_level, var_found,& not_recognized) ! ENDDO DEALLOCATE (var_names) DEALLOCATE (var_units) DEALLOCATE (var_sgnconv) DEALLOCATE (var_level) DEALLOCATE (var_max) DEALLOCATE (var_min) DEALLOCATE (var_found) ! END SUBROUTINE drv_almaparse ! !==================================================================== ! SUBROUTINE almaqc_getconf(conf_unit, nbvar_max, check, nbvar,& & var_names, var_units, var_sgnconv, var_level, var_max, var_min) ! ! ! This routine should be able to read directly the text version of the ! HTML page on quality control found at ! http://www.lmd.jussieu.fr/~polcher/ALMA/qc_values.html ! ! ARGUMENTS ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: conf_unit INTEGER, INTENT(IN) :: nbvar_max LOGICAL, INTENT(IN) :: check ! INTEGER, INTENT(OUT) :: nbvar CHARACTER(LEN=80), INTENT(OUT) :: var_names(nbvar_max), var_units(nbvar_max) CHARACTER(LEN=1), INTENT(OUT) :: var_sgnconv(nbvar_max), var_level(nbvar_max) REAL, INTENT(OUT) :: var_max(nbvar_max), var_min(nbvar_max) ! ! LOCAL ! INTEGER :: iret, iret2, iret3 INTEGER :: readlen, blk1, blk2, blk3, blk4, blk5, pt1, pt2 CHARACTER(LEN=250) :: readline CHARACTER(LEN=3) :: tl, dl CHARACTER(LEN=10) :: fmt ! ! Open configuration file ! !PAD OPEN(unit=conf_unit, file=conf_file, STATUS='OLD', IOSTAT=iret) rewind (conf_unit) ! !PAD IF ( iret .NE. 0 ) THEN !PAD WRITE(6,*) 'Could not open file ', conf_file(1:len_trim(conf_file)) !PAD WRITE(6,*) 'Please use option -cf to provide another filename for' !PAD WRITE(6,*) 'for the configuration file' !PAD STOP !PAD ENDIF ! iret = 0 IF ( check ) THEN WRITE (6,*) 'Reading ALMA standards configuration file' ENDIF ! DO WHILE (iret .EQ. 0) ! READ (conf_unit,'(A250)',IOSTAT=iret) readline ! Take out all redundant blanks CALL cmpblank(readline) readline = ADJUSTL(readline) ! ! ! Find the elements we need in this line. These ! are very simple : ! - 5 blanks ! - a dot in the 3rd and 4th word ! readlen = len_trim(readline) blk1 = index(readline(1:readlen),' ') blk2 = index(readline(blk1+1:readlen),' ')+blk1 blk3 = index(readline(blk2+1:readlen),' ')+blk2 blk4 = index(readline(blk3+1:readlen),' ')+blk3 blk5 = index(readline(blk4+1:readlen),' ')+blk4 pt1 = index(readline(blk2+1:blk3),".") pt2 = index(readline(blk3+1:blk4),".") ! ! ! Obviously we will only decode this line if we have found the 5 blanks and the two dots ! IF ( iret .EQ. 0 .AND. blk5 .GT. 0 .AND. pt1*pt2 .GT. 0) THEN ! ! Now take the variable out of that line ! var_names(nbvar+1) = readline(1:blk1) var_units(nbvar+1) = readline(blk1+1:blk2) CALL restexponent(var_units(nbvar+1)) ! Compute the format for the numbers as some compilers ! do not support wild cards in this case. WRITE(tl,'(I3.3)') blk3-blk2-1 WRITE(dl,'(I3.3)') blk3-blk2-1 - pt1 fmt = '(f'//tl//'.'//dl//')' READ (readline(blk2+1:blk3),FMT=fmt,IOSTAT=iret2) var_min(nbvar+1) WRITE(tl,'(I3.3)') blk4-blk3-1 WRITE(dl,'(I3.3)') blk4-blk3-1 - pt2 fmt = '(f'//tl//'.'//dl//')' READ (readline(blk3+1:blk4),FMT=fmt,IOSTAT=iret3) var_max(nbvar+1) var_sgnconv(nbvar+1) = readline(blk4+1:blk5) CALL struppercase(var_sgnconv(nbvar+1)) var_level(nbvar+1) = readline(blk5+1:readlen) CALL struppercase(var_level(nbvar+1)) ! ! Check if the READ went well ! IF ( iret2 .EQ. 0 .AND. iret3 .EQ. 0) THEN nbvar = nbvar + 1 ! IF ( nbvar+1 .GT. nbvar_max) THEN WRITE(6,*) 'Insufficient memory to store all variables' WRITE(6,*) 'Use the option -vm to allow for a larger number' WRITE(6,*) 'of variable to be checked' STOP ENDIF ! IF ( check ) THEN WRITE(6,'("-->",A20,A10,f14.4,f14.4," sgn : ",A1," level : ", A1)') & & var_names(nbvar), var_units(nbvar),& & var_min(nbvar), var_max(nbvar), var_sgnconv(nbvar), var_level(nbvar) ENDIF ! ELSE WRITE(6,*) 'Could not read the numbers in this line' WRITE(6,*) readline(1:readlen) STOP ENDIF ! ! ENDIF ! ENDDO ! IF ( check ) THEN WRITE(6,*) 'Found information for ', nbvar,' variables.' ENDIF ! END SUBROUTINE almaqc_getconf ! !==================================================================== ! SUBROUTINE almaqc_checkvar(ncid, nbvar, var_names, var_units, var_sgnconv, var_level,& & var_max, var_min, var_found, sgn_traditional, not_recognized, check, & & ncv_dim, ncv_info, ncv_index) ! ! ! Here we check the various variables in the file !PAD The intent here is just to report on the variables in the file, not to !PAD try and do anything about it if something is wrong. -PAD ! USE netcdf IMPLICIT NONE ! Data type for NetCDF variable info ! ! ARGUMENTS ! INTEGER, INTENT(IN) :: ncid INTEGER, INTENT(IN) :: nbvar CHARACTER(LEN=80), INTENT(IN) :: var_names(nbvar), var_units(nbvar) CHARACTER(LEN=1), INTENT(IN) :: var_sgnconv(nbvar), var_level(nbvar) REAL, INTENT(IN) :: var_max(nbvar), var_min(nbvar) INTEGER, INTENT(IN) :: ncv_dim ! Dim of ncv_ arrays TYPE(nc_pointer), INTENT(INOUT) :: ncv_info(ncv_dim) ! Structure for NetCDF input info INTEGER, INTENT(INOUT) :: ncv_index ! Number of variables found LOGICAL, INTENT(INOUT) :: var_found(nbvar) CHARACTER(LEN=250), INTENT(INOUT):: not_recognized LOGICAL, INTENT(IN) :: sgn_traditional LOGICAL, INTENT(IN) :: check LOGICAL :: check_force = .false. ! ! LOCAL ! INTEGER :: iret, iv, id, ii, is, il INTEGER :: var_infile CHARACTER(LEN=320) :: name_infile, units_infile INTEGER :: dimids(4), totsize, dimsize(4) LOGICAL :: found_units, found_missing, found_redund INTEGER :: found_variable REAL, ALLOCATABLE :: varval(:) REAL :: missing REAL :: fmin, fmax INTEGER :: varval_sz INTEGER :: test_index INTEGER :: xtype ! ! not_recognized = ' ' varval_sz = 0 ! iret = NF90_INQUIRE(ncid, nVariables = var_infile) ! ! Loop through variables in the file ! DO iv = 1 , var_infile ! ! Get the name and size of variable ! dimids(:) = -1 dimsize(:) = 1 ! iret = NF90_INQUIRE_VARIABLE(ncid, iv, name = name_infile, dimids = dimids, xtype = xtype) ! DO id=1,4 IF ( dimids(id) .GE. 0) THEN iret = NF90_INQUIRE_DIMENSION(ncid, dimids(id), len = dimsize(id)) ENDIF ENDDO totsize = dimsize(1)*dimsize(2)*dimsize(3)*dimsize(4) ! ! Get the units ! units_infile = ' ' iret = NF90_GET_ATT(ncid, iv, 'units', units_infile) IF ( iret .NE. NF90_NOERR ) THEN iret = NF90_GET_ATT(ncid, iv, 'UNITS', units_infile) IF ( iret .NE. NF90_NOERR ) THEN found_units = .FALSE. ELSE found_units = .TRUE. ENDIF ELSE found_units = .TRUE. ENDIF ! ! Get missing_value ! iret = NF90_GET_ATT(ncid, iv, 'missing_value', missing) IF ( iret .NE. NF90_NOERR ) THEN iret = NF90_GET_ATT(ncid, iv, 'MISSING_value', missing) IF ( iret .NE. NF90_NOERR ) THEN found_missing = .FALSE. ELSE found_missing = .TRUE. ENDIF ELSE found_missing = .TRUE. ENDIF ! ! Is this variable redundant with one already found? ! found_redund = .FALSE. DO id = 1, ncv_index IF ( name_infile(1:len_trim(name_infile)) .EQ. & & ncv_info(id)%ncname(1:len_trim(ncv_info(id)%ncname)) ) THEN found_redund = .TRUE. WRITE(6,*) WRITE(6,*) 'Variable number ',iv,' in file NCID = ',ncid WRITE(6,*) 'Named : <',name_infile(1:len_trim(name_infile)), & & '> is redundant with :' WRITE(6,*) 'Variable number ',ncv_info(id)%varid, & &' in file NCID = ',ncv_info(id)%ncid WRITE(6,*) 'Using first instance of ',name_infile(1:len_trim(name_infile)) ENDIF ENDDO redundant: IF ( .NOT. found_redund ) THEN ! ! Does this variable exists in the almaqc.conf file and was it ! not found before ? ! found_variable = 0 DO id = 1, nbvar IF ( index(var_names(id), name_infile(1:len_trim(name_infile))) .GT. 0 .AND.& & len_trim(var_names(id)) .EQ. len_trim(name_infile)) THEN IF ( found_variable .EQ. 0 ) THEN found_variable = id ENDIF var_found(id) = .TRUE. ENDIF ENDDO ! ! If so, we start to work ! WRITE(6,*) WRITE(6,*) 'Variable number ',iv,' in file NCID = ',ncid IF ( found_variable .GT. 0 ) THEN ! ! Inform user ! IF ( check ) THEN WRITE(6,'("ALMA variable :",A15,", ")') name_infile(1:len_trim(name_infile)) WRITE(6,*) 'Conf file position :', found_variable WRITE(6,*) 'Conf file line, Name : ', var_names(found_variable)(1:len_trim(var_names(found_variable))) WRITE(6,*) 'Conf file line, Units : ', var_units(found_variable)(1:len_trim(var_units(found_variable))) WRITE(6,*) 'Conf file line, Range : ', var_min(found_variable), var_max(found_variable) WRITE(6,*) 'Conf file line, Level : ', var_level(found_variable) ELSE WRITE(6,'("ALMA variable :",A15,", ",$)') name_infile(1:len_trim(name_infile)) ENDIF DO id=1,4 IF ( dimids(id) .GE. 0) THEN WRITE(6,*) id,' dimsize=',dimsize(id) ENDIF ENDDO ! ! Get the memory to store the variable ! IF ( varval_sz .LT. totsize) THEN IF (.NOT. ALLOCATED(varval) ) THEN ALLOCATE(varval(totsize), stat=iret) varval_sz = totsize ELSE DEALLOCATE(varval) ALLOCATE(varval(totsize), stat=iret) varval_sz = totsize ENDIF IF (iret.NE.0) THEN WRITE (6,*) ' Could not allocate real varval of size ', totsize STOP 'almaqc_checkvar' ENDIF ENDIF ! ! Check units ! IF ( index(units_infile,var_units(found_variable)) .GT. 0 .AND.& & len_trim(units_infile) .EQ. len_trim(var_units(found_variable))) THEN WRITE(6,'(A17,$)') 'Units are OK, ' ELSE WRITE(6,*) 'Problem on units : expected = ', var_units(found_variable),' found = ',& & units_infile(1:len_trim(units_infile)) ENDIF ncv_index = ncv_index + 1 ncv_info(ncv_index) = nc_pointer(name_infile(1:len_trim(name_infile)),ncid,iv) ! ! Read the data from the file ! if(check_force) then CALL drv_rd_nf(ncid, iv, varval_sz, xtype, dimsize, varval) ! ! All checks are performed in the traditional sign convention. Thus ! if the file follows the mathematical convention and the variable is ! sensitive to the convention then we need to change its sign. ! IF ( (.NOT. sgn_traditional) .AND. var_sgnconv(found_variable) .EQ. 'Y' ) THEN DO ii = 1, totsize IF ( ABS(varval(ii) - missing) .GT. EPSILON(missing)) THEN varval(ii) = varval(ii) * (-1.0) ENDIF ENDDO ENDIF ! ! Compute the min and max values of the field. ! IF ( found_missing ) THEN IF ( missing .GT. var_max(found_variable)) THEN fmin = MINVAL(varval(1:totsize), MASK=varval(1:totsize) .LT. missing) fmax = MAXVAL(varval(1:totsize), MASK=varval(1:totsize) .LT. missing) ELSE IF (missing .LT. var_min(found_variable)) THEN fmin = MINVAL(varval(1:totsize), MASK=varval(1:totsize) .GT. missing) fmax = MAXVAL(varval(1:totsize), MASK=varval(1:totsize) .GT. missing) ELSE WRITE(6,*) 'The missing value for this variable is within the allowed' WRITE(6,*) 'range of the variable' STOP ENDIF ELSE fmin = MINVAL(varval(1:totsize)) fmax = MAXVAL(varval(1:totsize)) ENDIF ! ! Do the check on the range ! IF ( fmin .GE. var_min(found_variable) .AND. fmax .LE. var_max(found_variable) ) THEN WRITE(6,*) 'Range is OK, min/max =', fmin, fmax ELSE WRITE(6,*) 'Variables out of range, min/max =', fmin, fmax ENDIF !! print *,">",name_infile(1:len_trim(name_infile)),":" IF ( name_infile(1:len_trim(name_infile)) == 'lon' ) THEN !! print *,">",name_infile(1:len_trim(name_infile)),":",fmin, fmax ELSEIF ( name_infile(1:len_trim(name_infile)) == 'lat' ) THEN !! print *,">",name_infile(1:len_trim(name_infile)),":",fmin,fmax ENDIF endif ! ELSE ! ! In case the variable does not exist in almaqc.conf we add it ! to the list ! is = len_trim(not_recognized) il = len_trim(name_infile) IF ( is .LE. 1 ) THEN not_recognized(is+1:is+il) = name_infile(1:il) ELSE not_recognized(is+1:is+il+2) = ', '//name_infile(1:il) ENDIF ! Inform WRITE(6,'("Non-ALMA variable :",A15,", ")') name_infile(1:len_trim(name_infile)) DO id=1,4 IF ( dimids(id) .GE. 0) THEN WRITE(6,*) id,' dimsize=',dimsize(id) ENDIF ENDDO ! ! Get the memory to store the variable ! IF ( varval_sz .LT. totsize) THEN IF (.NOT. ALLOCATED(varval) ) THEN ALLOCATE(varval(totsize), stat=iret) varval_sz = totsize ELSE DEALLOCATE(varval) ALLOCATE(varval(totsize), stat=iret) varval_sz = totsize ENDIF IF (iret.NE.0) THEN WRITE (6,*) ' Could not allocate varval of size ', totsize STOP 'almaqc_checkvar' ENDIF ENDIF ! ! Report units ! WRITE(6,*) 'Units found = ', units_infile(1:len_trim(units_infile)) ! ! Read the data from the file ! if(check_force) then CALL drv_rd_nf(ncid, iv, varval_sz, xtype, dimsize, varval) ! ! Compute the min and max values of the field. ! IF ( found_missing ) THEN IF ( missing .GT. var_max(found_variable)) THEN fmin = MINVAL(varval(1:totsize), MASK=varval(1:totsize) .LT. missing) fmax = MAXVAL(varval(1:totsize), MASK=varval(1:totsize) .LT. missing) ELSE IF (missing .LT. var_min(found_variable)) THEN fmin = MINVAL(varval(1:totsize), MASK=varval(1:totsize) .GT. missing) fmax = MAXVAL(varval(1:totsize), MASK=varval(1:totsize) .GT. missing) ELSE WRITE(6,*) 'The missing value for this variable is within the allowed' WRITE(6,*) 'range of the variable' STOP ENDIF ELSE fmin = MINVAL(varval(1:totsize)) fmax = MAXVAL(varval(1:totsize)) ENDIF ! ! Report on the range ! WRITE(6,*) 'Range found, min/max =', fmin, fmax endif ENDIF ! ENDIF redundant ENDDO IF (ALLOCATED(varval) ) DEALLOCATE(varval) ! END SUBROUTINE almaqc_checkvar ! !==================================================================== ! ! SUBROUTINE almaqc_bilan(iff, nb_files, names, nbvar, var_names, var_level, var_found,& not_recognized) ! ! This routine will display a resume of variables found and which were checked ! IMPLICIT NONE ! ! Arguments ! INTEGER, INTENT(IN) :: iff, nb_files, nbvar CHARACTER(LEN=80), INTENT(IN) :: names(nb_files) CHARACTER(LEN=80), INTENT(IN) :: var_names(nbvar) CHARACTER(LEN=1), INTENT(IN) :: var_level(nbvar) LOGICAL, INTENT(IN) :: var_found(nbvar) CHARACTER(LEN=250), INTENT(IN) :: not_recognized ! ! LOCAL ! INTEGER :: iv, is, il, ol, rl, of, rf, ff, pp CHARACTER(LEN=250) :: varlist ! ! WRITE(6,*) WRITE(6,*) 'Resume of variables in file ', names(iff)(1:len_trim(names(iff))),' :' ! IF ( len_trim(not_recognized) .GT. 1) THEN WRITE(6,*) 'The variables which were not recognized and thus not checked are' WRITE(6,*) not_recognized(1:len_trim(not_recognized)) ENDIF ! varlist = ' ' ol = 0 rl = 0 of = 0 rf = 0 ff = 0 pp = 0 ! DO iv = 1, nbvar ! ! The Mandatory variables ! IF ( var_level(iv) .EQ. 'M' .AND. (.NOT. var_found(iv)) ) THEN is = len_trim(varlist) il = len_trim(var_names(iv)) IF ( is .LE. 1 ) THEN varlist(is+1:is+il) = var_names(iv)(1:il) ELSE varlist(is+1:is+il+2) = ', '//var_names(iv)(1:il) ENDIF ENDIF ! ! The recommended variables ! IF ( var_level(iv) .EQ. 'R' ) THEN rl = rl + 1 IF ( var_found(iv) ) THEN rf = rf + 1 ENDIF ENDIF ! ! The optional variables ! IF ( var_level(iv) .EQ. 'O' ) THEN ol = ol + 1 IF ( var_found(iv) ) THEN of = of + 1 ENDIF ENDIF ! ! The forcing variables ! IF ( var_level(iv) .EQ. 'F' ) THEN IF ( var_found(iv) ) THEN ff = ff + 1 ENDIF ENDIF ! ! The parameter variables ! IF ( var_level(iv) .EQ. 'P' ) THEN IF ( var_found(iv) ) THEN pp = pp + 1 ENDIF ENDIF ENDDO ! IF ( of .EQ. 0 .AND. rf .EQ. 0) THEN IF (ff .GT. 0 ) THEN WRITE(6,*) 'A forcing file was checked. No further comments.' ELSEIF (pp .GT. 0 ) THEN WRITE(6,*) 'A parameter file was checked. No further comments.' ELSE WRITE(6,*) 'None of the optional nor recommended variables were found' ENDIF ELSE IF ( len_trim(varlist) .GT. 1) THEN WRITE(6,*) 'The following MANDATORY variables are missing :' WRITE(6,*) varlist(1:len_trim(varlist)) ENDIF IF ( rf .GT. 0) THEN WRITE(6,'(F5.1,"% of the recommended variables were found")') (rf*100.)/rl ELSE WRITE(6,*) 'None of the recommended variables were found' ENDIF IF ( of .GT. 0) THEN WRITE(6,'(F5.1,"% of the optional variables were found")') (of*100.)/ol ELSE WRITE(6,*) 'None of the optional variables were found' ENDIF ENDIF WRITE(6,*) ' ' ! END SUBROUTINE almaqc_bilan ! !==================================================================== ! ! SUBROUTINE cmpblank (str) !--------------------------------------------------------------------- !- IMPLICIT NONE ! !--------------------------------------------------------------------- CHARACTER(LEN=*),INTENT(inout) :: str !- INTEGER :: lcc,ipb !--------------------------------------------------------------------- lcc = LEN_TRIM(str) ipb = 1 DO IF (ipb >= lcc) EXIT IF (str(ipb:ipb+1) == ' ') THEN str(ipb+1:) = str(ipb+2:lcc) lcc = lcc-1 ELSE ipb = ipb+1 ENDIF ENDDO END SUBROUTINE cmpblank ! !==================================================================== ! ! SUBROUTINE strlowercase (str) !--------------------------------------------------------------------- !- Converts a string into lowercase !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*) :: str !- INTEGER :: i,ic !--------------------------------------------------------------------- DO i=1,LEN_TRIM(str) ic = IACHAR(str(i:i)) IF ( (ic >= 65) .AND. (ic <= 90) ) str(i:i) = ACHAR(ic+32) ENDDO !----------------------------- END SUBROUTINE strlowercase ! !==================================================================== ! ! SUBROUTINE struppercase (str) !--------------------------------------------------------------------- !- Converts a string into uppercase !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*) :: str !- INTEGER :: i,ic !--------------------------------------------------------------------- DO i=1,LEN_TRIM(str) ic = IACHAR(str(i:i)) IF ( (ic >= 97) .AND. (ic <= 122) ) str(i:i) = ACHAR(ic-32) ENDDO !----------------------------- END SUBROUTINE struppercase ! !==================================================================== ! ! SUBROUTINE restexponent(str) ! !- In some cases we have lost the '^' which indicates an exposnent !- To put it back we will look for '2' and '3' and if they are not preceeded !- by '^' we put it back in ! IMPLICIT NONE !- CHARACTER(LEN=*) :: str !- INTEGER :: il, il2 !--------------------------------------------------------------------- ! IF ( index(str,'2') .GT. 0 ) THEN il = index(str,'2') ELSE il = index(str,'3') ENDIF ! DO WHILE ( il .GT. 0 .AND. str(il-1:il-1) .NE. '^' ) ! IF ( str(il-1:il-1) .NE. '^' ) THEN str = str(1:il-1)//'^'//str(il:len_trim(str)) ENDIF ! IF ( index(str(il+2:len_trim(str)),'2') .GT. 0 ) THEN il2 = index(str(il+2:len_trim(str)),'2') il = il + il2 + 1 ELSE il2 = index(str(il+2:len_trim(str)),'3') il = il + il2 + 1 ENDIF ! ENDDO ! END SUBROUTINE restexponent SUBROUTINE drv_rd_nf(ncid, iv, varval_sz, xtype, dimsize, varval) USE netcdf IMPLICIT NONE INTEGER :: iret, iv, ncid, varval_sz, xtype INTEGER :: ivarval(varval_sz) INTEGER :: dimsize(4), icount(4), istart(4) REAL :: varval(varval_sz) CHARACTER(len = 6) ctype ! istart = 1 icount = dimsize SELECT CASE(xtype) CASE(NF90_INT) ctype = 'int' iret = NF90_GET_VAR(ncid, iv, ivarval, istart, icount) varval = float(ivarval) CASE(NF90_FLOAT, NF90_DOUBLE) ctype = 'float' iret = NF90_GET_VAR(ncid, iv, varval, istart, icount) CASE DEFAULT WRITE(*,*) 'neither float, double nor integer' STOP END SELECT IF (iret.NE.0) THEN WRITE (6,*) ' Could not read ',ctype,' variable ',iv,' from ncid = ',ncid STOP 'almaqc_read ' ENDIF END SUBROUTINE drv_rd_nf SUBROUTINE drv_gsp2d !====================================================================== ! Description: This routine reads the ISLSCP 2-D fields (unformated ! and dehydrated) that are necessary for setting up LSS ! for the GSWP project runs. -14 March 1996 ! Revision: Modified to read ALMA-compliant fields, and make some ! decisions about parameter settings based on available data ! PAD - Jan 2002 ! $Log: drv_gsp2d.f90,v $ ! Revision 1.1 2002/08/16 15:57:47 guo ! Initial revision ! !====================================================================== USE drv_readnf_mod USE drv_dat_mod IMPLICIT NONE CHARACTER(len=15) :: a15 INTEGER :: i,j,k INTEGER :: iret INTEGER, DIMENSION(lonin,latin) :: iindat2D ALLOCATE ( glon (lpnts) ) ALLOCATE ( glat (lpnts) ) ALLOCATE ( fiindex (lpnts) ) ALLOCATE ( fjindex (lpnts) ) ALLOCATE ( fhmask (lpnts) ) ALLOCATE ( iindex (lpnts) ) ALLOCATE ( jindex (lpnts) ) ALLOCATE ( hmask (lpnts) ) !nf Read in mask file containing long, lat, and veg mask a15 = "Grid_Mask_x" iret = drv_readnf1(a15,ncvar_count,nc_input,fiindex,lpnts,'try') a15 = "Grid_Mask_y" iret = drv_readnf1(a15,ncvar_count,nc_input,fjindex,lpnts,'try') IF (iret .EQ. 1) THEN a15 = "LS_MASK" iret = drv_readnf2d(a15,ncvar_count,nc_input,iindat2D,lonin,latin) k=0 DO i = 1,lonin DO j = 1,latin IF (iindat2D(i,j) > 0) THEN k = k+1 fiindex(k) = i fjindex(k) = j ! write(*,*) 'land point: ',k,(j-1)*lonin+i,iindat2D(i,j) ENDIF ENDDO ENDDO ENDIF ! ! convert kinds of arrays iindex = int(fiindex) jindex = int(fjindex) DO i=1,lpnts hmask(i) = i ENDDO DO i=1,idp glev(i) = i ENDDO ! ! Read in navigation vectors print*, ' Read navigation vectors ' a15 = "nav_lon" iret = drv_readnf1(a15,ncin_dim,nc_input,glon,lpnts,'try') IF (iret .EQ. 1) THEN a15 = "lon" iret = drv_readnf1(a15,ncin_dim,nc_input,glon,lpnts) ENDIF a15 = "nav_lat" iret = drv_readnf1(a15,ncin_dim,nc_input,glat,lpnts,'try') IF (iret .EQ. 1) THEN a15 = "lat" iret = drv_readnf1(a15,ncin_dim,nc_input,glat,lpnts) ENDIF END SUBROUTINE drv_gsp2d ! END MODULE drv_input_mod