MODULE inp_decode_mod
!
!git $Id$
!svn $Id: inp_decode.F 1176 2023-07-01 19:23:18Z arango $
!================================================== Hernan G. Arango ===
! Copyright (c) 2002-2023 The ROMS/TOMS Group !
! Licensed under a MIT/X style license !
! See License_ROMS.md !
!=======================================================================
! !
! This module contains several routines to process and decode ROMS !
! unique namelist KeyWord parameters from input script files: !
! !
! decode_line Decodes line of text from input script files for a !
! particular KeyWord. !
! !
! find_file Checks if provide input filename exits. !
! !
! load_i Processes and loads an integer parameter variable. !
! !
! load_i Processes and loads a logical parameter variable. !
! !
! load_r Processes and loads a single or double precision !
! floating-point (real) parameter variable. !
! !
! load_lbc Processes and loads lateral boundary conditions !
! logical switches into derived type structure, !
! TYPE(T_LBC). !
! !
! load_s1d Processes and loads I/O parameters into 1D derived !
! type structure, TYPE(T_IO). !
! !
! load_s2d Processes and loads I/O parameters into 2D derived !
! type structure, TYPE(T_IO). !
! !
! load_tadv Processes and loads tracers horizontal and vertical !
! advection switches into derived type structure, !
! TYPE(T_ADV). !
! !
!=======================================================================
!
USE mod_kinds
USE mod_param
USE mod_parallel
USE mod_iounits
USE mod_ncparam
USE mod_netcdf
USE mod_scalars
!
USE strings_mod, ONLY : FoundError
USE strings_mod, ONLY : uppercase
!
implicit none
!
INTERFACE load_i
MODULE PROCEDURE load_0d_i ! scalar integer
MODULE PROCEDURE load_1d_i ! 1D integer array
MODULE PROCEDURE load_2d_i ! 2D integer array
MODULE PROCEDURE load_3d_i ! 3D integer array
END INTERFACE load_i
INTERFACE load_l
MODULE PROCEDURE load_0d_l ! scalar logical
MODULE PROCEDURE load_1d_l ! 1D logical array
MODULE PROCEDURE load_2d_l ! 2D logical array
MODULE PROCEDURE load_3d_l ! 3D logical array
END INTERFACE load_l
INTERFACE load_r
MODULE PROCEDURE load_0d_r8 ! scalar real(r8)
MODULE PROCEDURE load_1d_r8 ! 1D real(r8) array
MODULE PROCEDURE load_2d_r8 ! 2D real(r8) array
MODULE PROCEDURE load_3d_r8 ! 3D real(r8) array
END INTERFACE load_r
INTERFACE load_s1d
MODULE PROCEDURE load_s1d1 ! 1D structrure, S(:)
MODULE PROCEDURE load_s1d2 ! 2D structrure, S(Ie,:)
END INTERFACE load_s1d
!
! Module dimension parameters.
!
integer, parameter :: nCval = 200 ! size of Cval character vector
integer, parameter :: nRval = 100 ! size of Rval real vector
!
CONTAINS
!
FUNCTION decode_line (line_text, KeyWord, Nval, Cval, Rval)
!
!***********************************************************************
! !
! This function decodes lines of text from input script files. It is !
! to evaluate ROMS unique namelist parameters. !
! !
! Arguments: !
! !
! line_text Input scripts lines as text (string) !
! KeyWord Input parameter keyword (string) !
! Nval Number of values processed (integer) !
! Cval Input values as characters (string array) !
! Rval Input values as mumbers (real array) !
! !
!***********************************************************************
!
! Imported variable declarations.
!
character (len=*), intent(in) :: line_text
character (len=*), intent(inout) :: KeyWord
integer, intent(inout) :: Nval
character (len=*), intent(inout) :: Cval(:)
real(dp), intent(inout) :: Rval(:)
!
! Local variable declarations
!
logical :: IsString, Kextract, decode, nested
integer :: Iblank, Icomm, Icont, Ipipe, Kstr, Kend, Linp
integer :: Lend, LenS, Lstr, Lval, Nmul, Schar
integer :: copies, i, ic, ie, is, j, status
integer, dimension(20) :: Imul
integer :: decode_line
character (len=256) :: Vstring, inpline, line, string
!
!------------------------------------------------------------------------
! Decode input line.
!------------------------------------------------------------------------
!
! Initialize. Use CHAR(32) for blank space.
!
line=CHAR(32)
inpline=CHAR(32)
Vstring=CHAR(32)
string=CHAR(32)
!
! Check input line and remove illegal characters. Replace control
! ASCII characters CHAR(0) to CHAR(31) with a blank space, CHAR(32).
!
! Char Dec Key Control Action
! ----------------------------------------------------------------------
! NUL 0 ^@ Null character
! SOH 1 ^A Start of heading, = console interrupt
! STX 2 ^B Start of text, maintenance mode on HP console
! ETX 3 ^C End of text
! EOT 4 ^D End of transmission, not the same as ETB
! ENQ 5 ^E Enquiry, goes with ACK; old HP flow control
! ACK 6 ^F Acknowledge, clears ENQ logon hand
! BEL 7 ^G Bell, rings the bell...
! BS 8 ^H Backspace, works on HP terminals/computers
! HT 9 ^I Horizontal tab, move to next tab stop
! LF 10 ^J Line Feed
! VT 11 ^K Vertical tab
! FF 12 ^L Form Feed, page eject
! CR 13 ^M Carriage Return
! SO 14 ^N Shift Out, alternate character set
! SI 15 ^O Shift In, resume defaultn character set
! DLE 16 ^P Data link escape
! DC1 17 ^Q XON, with XOFF to pause listings; ":okay to send".
! DC2 18 ^R Device control 2, block-mode flow control
! DC3 19 ^S XOFF, with XON is TERM=18 flow control
! DC4 20 ^T Device control 4
! NAK 21 ^U Negative acknowledge
! SYN 22 ^V Synchronous idle
! ETB 23 ^W End transmission block, not the same as EOT
! CAN 24 ^X Cancel line, MPE echoes !!!
! EM 25 ^Y End of medium, Control-Y interrupt
! SUB 26 ^Z Substitute
! ESC 27 ^[ Escape, next character is not echoed
! FS 28 ^\ File separator
! GS 29 ^] Group separator
! RS 30 ^^ Record separator, block-mode terminator
! US 31 ^_ Unit separator
!
! SP 32 Space
! ! 33 Exclamation mark
! # 35 Number sign, hash, or pound sign
! * 42 Asterisk (star, multiply)
! + 43 Plus
! - 45 Hyphen, dash, minus
! . 46 Period
! 0 48 Zero
! 1 49 One
! 2 50 Two
! 3 51 Three
! 4 52 Four
! 5 53 Five
! 6 54 Six
! 7 55 Seven
! 8 56 Eight
! 9 57 Nine
! : 58 colon sign
! = 61 Equals sign
! \ 92 Reverse slant (Backslash)
! | 124 Vertical line
!
inpline=TRIM(ADJUSTL(line_text))
Linp=LEN_TRIM(inpline)
DO i=1,LEN_TRIM(inpline)
j=ICHAR(inpline(i:i))
IF (j.lt.32) THEN
inpline(i:i)=char(32) ! blank space
END IF
END DO
inpline=TRIM(inpline)
!
! Get length of "line". Remove comment after the KEYWORD, if any.
! Then, remove leading and trailing blanks.
!
IF ((Linp.gt.0).and.(inpline(1:1).ne.CHAR(33))) THEN
Icomm=INDEX(inpline,CHAR(33),BACK=.FALSE.)
IF (Icomm.gt.0) Linp=Icomm-1
line=TRIM(ADJUSTL(inpline(1:Linp)))
Linp=LEN_TRIM(line)
ELSE
line=TRIM(ADJUSTL(inpline))
Linp=LEN_TRIM(line)
END IF
!
! If not a blank or comment line [char(33)=!], decode and extract input
! values. Find equal sign [char(61)].
!
status=-1
nested=.FALSE.
IF ((Linp.gt.0).and.(line(1:1).ne.CHAR(33))) THEN
status=1
Kstr=1
Kend=INDEX(line,CHAR(61),BACK=.FALSE.)-1
Lstr=INDEX(line,CHAR(61),BACK=.TRUE.)+1
!
! Determine if KEYWORD is followed by double equal sign (==) indicating
! nested parameter.
!
IF ((Lstr-Kend).eq.3) nested=.TRUE.
!
! Extract KEYWORD, trim leading and trailing blanks.
!
Kextract=.FALSE.
IF (Kend.gt.0) THEN
Lend=Linp
KeyWord=line(Kstr:Kend)
Nval=0
Kextract=.TRUE.
ELSE
Lstr=1
Lend=Linp
Kextract=.TRUE.
END IF
!
! Extract parameter values string. Remove continuation symbol
! [char(92)=\] or multi-line value [char(124)=|], if any. Trim
! leading trailing blanks.
!
IF (Kextract) THEN
Icont=INDEX(line,CHAR(92 ),BACK=.FALSE.)
Ipipe=INDEX(line,CHAR(124),BACK=.FALSE.)
IF (Icont.gt.0) Lend=Icont-1
IF (Ipipe.gt.0) Lend=Ipipe-1
Vstring=ADJUSTL(line(Lstr:Lend))
Lval=LEN_TRIM(Vstring)
!
! The TITLE KEYWORD is a special one since it can include strings,
! numbers, spaces, and continuation symbol.
!
IsString=.FALSE.
IF (TRIM(KeyWord).eq.'TITLE') THEN
Nval=Nval+1
Cval(Nval)=Vstring(1:Lval)
IsString=.TRUE.
ELSE
!
! Check if there is a multiplication symbol [char(42)=*] in the variable
! string indicating repetition of input values.
!
Nmul=0
DO i=1,Lval
IF (Vstring(i:i).eq.CHAR(42)) THEN
Nmul=Nmul+1
Imul(Nmul)=i
END IF
END DO
ic=1
!
! Check for blank spaces [char(32)=' '] between entries and decode.
!
is=1
ie=Lval
Iblank=0
decode=.FALSE.
DO i=1,Lval
IF (Vstring(i:i).eq.CHAR(32)) THEN
IF (Vstring(i+1:i+1).ne.CHAR(32)) decode=.TRUE.
Iblank=i
ELSE
ie=i
ENDIF
IF (decode.or.(i.eq.Lval)) THEN
Nval=Nval+1
!
! Processing numeric values. Check starting character to determine
! if numeric or character values. It is possible to have both when
! processing repetitions via the multiplication symbol.
!
Schar=ICHAR(Vstring(is:is))
IF (((48.le.Schar).and.(Schar.le.57)).or. &
& (Schar.eq.43).or.(Schar.eq.45)) THEN
IF ((Nmul.gt.0).and. &
& (is.lt.Imul(ic)).and.(Imul(ic).lt.ie)) THEN
READ (Vstring(is:Imul(ic)-1),*) copies
Schar=ICHAR(Vstring(Imul(ic)+1:Imul(ic)+1))
IF ((43.le.Schar).and.(Schar.le.57)) THEN
READ (Vstring(Imul(ic)+1:ie),*) Rval(Nval)
DO j=1,copies-1
Rval(Nval+j)=Rval(Nval)
END DO
ELSE
string=Vstring(Imul(ic)+1:ie)
LenS=LEN_TRIM(string)
Cval(Nval)=string(1:LenS)
DO j=1,copies-1
Cval(Nval+j)=Cval(Nval)
END DO
END IF
Nval=Nval+copies-1
ic=ic+1
ELSE
string=Vstring(is:ie)
LenS=LEN_TRIM(string)
READ (string(1:LenS),*) Rval(Nval)
END IF
ELSE
!
! Processing character values (logicals and strings).
!
IF ((Nmul.gt.0).and. &
& (is.lt.Imul(ic)).and.(Imul(ic).lt.ie)) THEN
READ (Vstring(is:Imul(ic)-1),*) copies
Cval(Nval)=Vstring(Imul(ic)+1:ie)
DO j=1,copies-1
Cval(Nval+j)=Cval(Nval)
END DO
Nval=Nval+copies-1
ic=ic+1
ELSE
string=Vstring(is:ie)
Cval(Nval)=TRIM(ADJUSTL(string))
END IF
IsString=.TRUE.
END IF
is=Iblank+1
ie=Lval
decode=.FALSE.
END IF
END DO
END IF
END IF
status=Nval
END IF
decode_line=status
!
RETURN
END FUNCTION decode_line
!
FUNCTION find_file (ng, out, fname, KeyWord) RESULT (foundit)
!
!***********************************************************************
! !
! This function checks if provided input file exits. !
! !
! On Input: !
! !
! ng Nested grid number !
! out Standard output unit !
! fname Filename (path and name) !
! KeyWord Keyword associated with file name (string,OPTIONAL) !
! !
! On Output: !
! !
! foundit The value of the result is TRUE/FALSE if the file !
! was found or not !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: ng, out
!
character (len=*), intent(in) :: fname
character (len=*), intent(in) :: KeyWord
!
! Local variable declarations.
!
logical :: foundit, isURL
!
integer :: lstr, ncid
!
character (len=*), parameter :: MyFile = &
& "ROMS/Utility/inp_decode.F"//", find_file"
!
SourceFile=MyFile
!
!-----------------------------------------------------------------------
! Check if the file exit.
!-----------------------------------------------------------------------
!
foundit=.FALSE.
!
! Check for empty file name string.
!
lstr=LEN_TRIM(fname)
IF (lstr.eq.0) THEN
IF (Master) THEN
WRITE (stdout,10) TRIM(KeyWord)
10 FORMAT (/,' FIND_FILE - empty file name string ', &
& 'for standard input script KeyWord: ',a)
END IF
exit_flag=5
IF (FoundError(exit_flag, NoError, 438, MyFile)) RETURN
END IF
!
! Check if provided file is a URL. This implies the file is a NetCDF
! file on Data Access Protocol (DAP) server (like OPeNDAP).
!
isURL=.FALSE.
IF (INDEX(TRIM(fname),'http:').ne.0) THEN
isURL=.TRUE.
END IF
!
! Use F90 intrinsic function for non URL files.
!
IF (.not.isURL) THEN
INQUIRE (FILE=TRIM(fname), EXIST=foundit)
!
! Use NetCDF library (version 4.1.1 or higher) to check URL NetCDF
! files.
!
ELSE
CALL netcdf_open (ng, iNLM, fname, 0, ncid)
IF (exit_flag.eq.NoError) THEN
foundit=.TRUE.
CALL netcdf_close (ng, iNLM, ncid, fname, .FALSE.)
END IF
END IF
!
! Report if not found.
!
IF (.not.foundit) THEN
IF (Master) WRITE (out,20) ng, TRIM(fname)
20 FORMAT (/,' FIND_FILE - Grid ',i2.2, &
& ', cannot find input file: ',a)
exit_flag=5
END IF
!
RETURN
END FUNCTION find_file
!
FUNCTION load_0d_i (Ninp, Vinp, Nout, Vout) RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model scalar integer !
! variable. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Nout Size of output integer variable dimension (not used) !
! !
! On Output: !
! !
! Vout Output scalar integer variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Nout
real(dp), intent(in) :: Vinp(:)
!
integer, intent(out) :: Vout
!
! Local variable declarations.
!
integer :: ic
integer :: Nval
!
!-----------------------------------------------------------------------
! Load scalar integer variable with input value.
!-----------------------------------------------------------------------
!
ic=1
Vout=INT(Vinp(ic))
Nval=ic
RETURN
END FUNCTION load_0d_i
!
FUNCTION load_1d_i (Ninp, Vinp, Nout, Vout) RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 1D integer array. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Nout Size of output integer variable dimension !
! !
! On Output: !
! !
! Vout Output 1D integer variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Nout
real(dp), intent(in) :: Vinp(:)
!
integer, intent(out) :: Vout(:)
!
! Local variable declarations.
!
integer :: Nstr, i, ic
integer :: Nval
!
!-----------------------------------------------------------------------
! Load 1D integer variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the array.
!
ic=0
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
Vout(i)=INT(Vinp(i))
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vout(i)=INT(Vinp(Ninp))
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
Vout(i)=INT(Vinp(i))
END DO
END IF
Nval=ic
RETURN
END FUNCTION load_1d_i
!
FUNCTION load_2d_i (Ninp, Vinp, Iout, Jout, Vout) RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 2D integer array. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Iout Size of output integer variable first I-dimension !
! Jout Size of output integer variable second J-dimension !
! !
! On Output: !
! !
! Vout Output 2D integer variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Iout, Jout
real(dp), intent(in) :: Vinp(:)
!
integer, intent(out) :: Vout(:,:)
!
! Local variable declarations.
!
integer :: Nstr, i, ic
integer :: Nout, Nval
!
integer, dimension(Iout*Jout) :: Vwrk
!
!-----------------------------------------------------------------------
! Load 2D integer variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the 2D array.
!
ic=0
Nout=Iout*Jout
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
Vwrk(i)=INT(Vinp(i))
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vwrk(i)=INT(Vinp(Ninp))
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
Vwrk(i)=INT(Vinp(i))
END DO
END IF
Vout=RESHAPE(Vwrk,(/Iout,Jout/))
Nval=ic
!
RETURN
END FUNCTION load_2d_i
!
FUNCTION load_3d_i (Ninp, Vinp, Iout, Jout, Kout, Vout) &
& RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 3D integer array. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Iout Size of output integer variable first I-dimension !
! Jout Size of output integer variable second J-dimension !
! Kout Size of output integer variable third K-dimension !
! !
! On Output: !
! !
! Vout Output 3D integer variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Iout, Jout, Kout
real(dp), intent(in) :: Vinp(:)
!
integer, intent(out) :: Vout(:,:,:)
!
! Local variable declarations.
!
integer :: Nstr, i, ic
integer :: Nout, Nval
!
integer, dimension(Iout*Jout*Kout) :: Vwrk
!
!-----------------------------------------------------------------------
! Load 3D integer variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the 3D array.
!
ic=0
Nout=Iout*Jout*Kout
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
Vwrk(i)=INT(Vinp(i))
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vwrk(i)=INT(Vinp(Ninp))
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
Vwrk(i)=INT(Vinp(i))
END DO
END IF
Vout=RESHAPE(Vwrk,(/Iout,Jout,Kout/))
Nval=ic
!
RETURN
END FUNCTION load_3d_i
!
FUNCTION load_0d_l (Ninp, Vinp, Nout, Vout) RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model scalar logical !
! variable. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (character 1D array) !
! Nout Size of output logical variable dimension (not used) !
! !
! On Output: !
! !
! Vout Output scalar logical variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Nout
character (len=*), intent(in) :: Vinp(:)
!
logical, intent(out) :: Vout
!
! Local variable declarations.
!
integer :: ic
integer :: Nval
!
!-----------------------------------------------------------------------
! Load scalar logical variable with input value.
!-----------------------------------------------------------------------
!
ic=1
IF ((Vinp(ic)(1:1).eq.'T').or. &
& (Vinp(ic)(1:1).eq.'t')) THEN
Vout=.TRUE.
ELSE
Vout=.FALSE.
END IF
Nval=ic
!
RETURN
END FUNCTION load_0d_l
!
FUNCTION load_1d_l (Ninp, Vinp, Nout, Vout) RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 1D logical array. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (character 1D array) !
! Nout Size of output logical variable dimension !
! !
! On Output: !
! !
! Vout Output 1D logical variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Nout
character (len=*), intent(in) :: Vinp(:)
!
logical, intent(out) :: Vout(:)
!
! Local variable declarations.
!
logical :: LastValue
integer :: Nstr, i, ic
integer :: Nval
!
!-----------------------------------------------------------------------
! Load logical variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the array.
!
ic=0
LastValue=.FALSE.
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
IF ((Vinp(i)(1:1).eq.'T').or. &
& (Vinp(i)(1:1).eq.'t')) THEN
Vout(i)=.TRUE.
ELSE
Vout(i)=.FALSE.
END IF
LastValue=Vout(i)
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vout(i)=LastValue
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
IF ((Vinp(i)(1:1).eq.'T').or. &
& (Vinp(i)(1:1).eq.'t')) THEN
Vout(i)=.TRUE.
ELSE
Vout(i)=.FALSE.
END IF
END DO
END IF
Nval=ic
!
RETURN
END FUNCTION load_1d_l
!
FUNCTION load_2d_l (Ninp, Vinp, Iout, Jout, Vout) RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 2D logical array. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (character 1D array) !
! Iout Size of output logical variable first I-dimension !
! Jout Size of output logical variable second J-dimension !
! !
! On Output: !
! !
! Vout Output 2D logical variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Iout, Jout
character (len=*), intent(in) :: Vinp(:)
!
logical, intent(out) :: Vout(:,:)
!
! Local variable declarations.
!
logical :: LastValue
!
logical, dimension(Iout*Jout) :: Vwrk
!
integer :: Nstr, i, ic
integer :: Nout, Nval
!
!-----------------------------------------------------------------------
! Load 2D logical variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the array.
!
ic=0
Nout=Iout*Jout
LastValue=.FALSE.
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
IF ((Vinp(i)(1:1).eq.'T').or. &
& (Vinp(i)(1:1).eq.'t')) THEN
Vwrk(i)=.TRUE.
ELSE
Vwrk(i)=.FALSE.
END IF
LastValue=Vwrk(i)
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vwrk(i)=LastValue
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
IF ((Vinp(i)(1:1).eq.'T').or. &
& (Vinp(i)(1:1).eq.'t')) THEN
Vwrk(i)=.TRUE.
ELSE
Vwrk(i)=.FALSE.
END IF
END DO
END IF
Vout=RESHAPE(Vwrk,(/Iout,Jout/))
Nval=ic
!
RETURN
END FUNCTION load_2d_l
!
FUNCTION load_3d_l (Ninp, Vinp, Iout, Jout, Kout, Vout) &
& RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 3D logical array. !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (character 1D array) !
! Iout Size of output logical variable first I-dimension !
! Jout Size of output logical variable second J-dimension !
! Kout Size of output logical variable third K-dimension !
! !
! On Output: !
! !
! Vout Output 3D logical variable !
! Nval Number of output values processed !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Iout, Jout, Kout
character (len=*), intent(in) :: Vinp(:)
!
logical, intent(out) :: Vout(:,:,:)
!
! Local variable declarations.
!
logical :: LastValue
!
logical, dimension(Iout*Jout*Kout) :: Vwrk
!
integer :: Nstr, i, ic
integer :: Nout, Nval
!
!-----------------------------------------------------------------------
! Load 3D logical variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the array.
!
ic=0
Nout=Iout*Jout*Kout
LastValue=.FALSE.
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
IF ((Vinp(i)(1:1).eq.'T').or. &
& (Vinp(i)(1:1).eq.'t')) THEN
Vwrk(i)=.TRUE.
ELSE
Vwrk(i)=.FALSE.
END IF
LastValue=Vwrk(i)
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vwrk(i)=LastValue
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
IF ((Vinp(i)(1:1).eq.'T').or. &
& (Vinp(i)(1:1).eq.'t')) THEN
Vwrk(i)=.TRUE.
ELSE
Vwrk(i)=.FALSE.
END IF
END DO
END IF
Vout=RESHAPE(Vwrk,(/Iout,Jout,Kout/))
Nval=ic
!
RETURN
END FUNCTION load_3d_l
!
FUNCTION load_0d_r8 (Ninp, Vinp, Nout, Vout) RESULT (Nval)
!
!=======================================================================
! !
! It loads input values into a requested model scalar floating-point !
! variable (KIND=r8). !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Nout Size of output integer variable dimension (not used) !
! !
! On Output: !
! !
! Vout Output scalar variable (real, KIND=r8) !
! Nval Number of output values processed !
! !
!=======================================================================
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Nout
real(dp), intent(in) :: Vinp(:)
!
real(r8), intent(out) :: Vout
!
! Local variable declarations.
!
integer :: ic
integer :: Nval
!
!-----------------------------------------------------------------------
! Load scalar floating-point variable with input value.
!-----------------------------------------------------------------------
!
ic=1
Vout=Vinp(ic)
Nval=ic
!
RETURN
END FUNCTION load_0d_r8
!
FUNCTION load_1d_r8 (Ninp, Vinp, Nout, Vout) RESULT (Nval)
!
!=======================================================================
! !
! It loads input values into a requested model 1D floating-point !
! array (KIND=r8). !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Nout Size of output integer variable dimension !
! !
! On Output: !
! !
! Vout Output 1D variable (real, KIND=r8) !
! Nval Number of output values processed !
! !
!=======================================================================
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Nout
real(dp), intent(in) :: Vinp(:)
!
real(r8), intent(out) :: Vout(:)
!
! Local variable declarations.
!
integer :: Nstr, i, ic
integer :: Nval
!
!-----------------------------------------------------------------------
! Load 1D floating-point variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the array.
!
ic=0
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
Vout(i)=Vinp(i)
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vout(i)=Vinp(Ninp)
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
Vout(i)=Vinp(i)
END DO
END IF
Nval=ic
!
RETURN
END FUNCTION load_1d_r8
!
FUNCTION load_2d_r8 (Ninp, Vinp, Iout, Jout, Vout) RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 2D floating-point !
! array (KIND=r8). !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Iout Size of output integer variable first I-dimension !
! Jout Size of output integer variable second J-dimension !
! !
! On Output: !
! !
! Vout Output 2D variable (real, KIND=r8) !
! Nval Number of output values processed !
! !
!=======================================================================
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Iout, Jout
real(dp), intent(in) :: Vinp(:)
!
real(r8), intent(out) :: Vout(:,:)
!
! Local variable declarations.
!
integer :: Nstr, i, ic
integer :: Nout, Nval
!
real(r8), dimension(Iout*Jout) :: Vwrk
!
!-----------------------------------------------------------------------
! Load 2D floating-point variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the array.
!
ic=0
Nout=Iout*Jout
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
Vwrk(i)=Vinp(i)
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vwrk(i)=Vinp(Ninp)
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
Vwrk(i)=Vinp(i)
END DO
END IF
Vout=RESHAPE(Vwrk,(/Iout,Jout/))
Nval=ic
!
RETURN
END FUNCTION load_2d_r8
!
FUNCTION load_3d_r8 (Ninp, Vinp, Iout, Jout, Kout, Vout) &
& RESULT (Nval)
!
!***********************************************************************
! !
! It loads input values into a requested model 3D floating-point !
! array (KIND=r8). !
! !
! On Input: !
! !
! Ninp Number of input elements to process in Vinp (integer) !
! Vinp Input values (1D real(dp) array) !
! Iout Size of output integer variable first I-dimension !
! Jout Size of output integer variable second J-dimension !
! Kout Size of output integer variable third K-dimension !
! !
! On Output: !
! !
! Vout Output 3D variable (real, KIND=r8) !
! Nval Number of output values processed !
! !
!=======================================================================
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, Iout, Jout, Kout
real(dp), intent(in) :: Vinp(:)
!
real(r8), intent(out) :: Vout(:,:,:)
!
! Local variable declarations.
!
integer :: Nstr, i, ic
integer :: Nout, Nval
!
real(r8), dimension(Iout*Jout*Kout) :: Vwrk
!
!-----------------------------------------------------------------------
! Load 3D floating-point variable with input values.
!-----------------------------------------------------------------------
!
! If not all values are provided for variable, assume the last value
! for the rest of the array.
!
ic=0
Nout=Iout*Jout*Kout
IF (Ninp.le.Nout) THEN
DO i=1,Ninp
ic=ic+1
Vwrk(i)=Vinp(i)
END DO
IF (Nout.gt.Ninp) THEN
Nstr=Ninp+1
DO i=Nstr,Nout
ic=ic+1
Vwrk(i)=Vinp(Ninp)
END DO
END IF
ELSE
DO i=1,Nout
ic=ic+1
Vwrk(i)=Vinp(i)
END DO
END IF
Vout=RESHAPE(Vwrk,(/Iout,Jout,Kout/))
Nval=ic
!
RETURN
END FUNCTION load_3d_r8
!
FUNCTION load_lbc (Ninp, Vinp, line, nline, ifield, igrid, &
& iTrcStr, iTrcEnd, svname, S)
!
!***********************************************************************
! !
! This function sets lateral boundary conditions logical switches !
! according to input string keywords. !
! !
! On Input: !
! !
! Ninp Size of input variable (integer) !
! Vinp Input values (string) !
! line Current input line (string) !
! nline Multi-line counter (integer) !
! ifield Lateral boundary variable index (integer) !
! igrid Nested grid counter (integer) !
! iTrcStr Starting tracer index to process (integer) !
! iTrcEnd Ending tracer index to process (integer) !
! svname State variable name (string) !
! S Derived type structure, TYPE(T_LBC) !
! !
! On Output: !
! !
! nline Updated multi-line counter (integer) !
! igrid Updated nested grid counter (integer) !
! S Updated derived type structure, TYPE(T_LBC) !
! load_lbc Number of output values processed. !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, ifield, iTrcStr, iTrcEnd
integer, intent(inout) :: igrid, nline
character (len=256), intent(in) :: line
character (len=256), intent(in) :: Vinp(Ninp)
character (len=* ), intent(in) :: svname
TYPE(T_LBC), intent(inout) :: S(4,nLBCvar,Ngrids)
!
! Local variable declarations.
!
integer :: Icont, i, ib, ic
integer :: load_lbc
character (len=10) :: Bstring(4), string
!
!-----------------------------------------------------------------------
! Set lateral boundary conditions switches in structure.
!-----------------------------------------------------------------------
!
! Check current line for the continuation symbol [char(92)=\].
!
Icont=INDEX(TRIM(line),CHAR(92) ,BACK=.FALSE.)
!
! Extract lateral boundary condition keywords from Vinp. Notice that
! additional array elements are added to Vinp during continuation
! lines.
!
i=nline*4
Bstring(1)=TRIM(Vinp(i+1))
Bstring(2)=TRIM(Vinp(i+2))
Bstring(3)=TRIM(Vinp(i+3))
Bstring(4)=TRIM(Vinp(i+4))
!
! Advance or reset entry lines counter.
!
IF (Icont.gt.0) THEN
nline=nline+1
ELSE
nline=0
END IF
!
! Set switches for each boundary segment.
!
ic=1
IF ((0.lt.ifield).and.(ifield.le.nLBCvar)) THEN
DO ib=1,4
string=uppercase(Bstring(ib))
SELECT CASE (TRIM(string))
CASE ('CHA')
S(ib,ifield,igrid)%Chapman_implicit = .TRUE.
CASE ('CHE')
S(ib,ifield,igrid)%Chapman_explicit = .TRUE.
CASE ('CLA')
S(ib,ifield,igrid)%clamped = .TRUE.
S(ib,ifield,igrid)%acquire = .TRUE.
CASE ('CLO')
S(ib,ifield,igrid)%closed = .TRUE.
CASE ('FLA')
S(ib,ifield,igrid)%Flather = .TRUE.
S(ib,ifield,igrid)%acquire = .TRUE.
S(ib,isFsur,igrid)%acquire = .TRUE.
CASE ('GRA')
S(ib,ifield,igrid)%gradient = .TRUE.
CASE ('MIX')
S(ib,ifield,igrid)%mixed = .TRUE.
S(ib,ifield,igrid)%acquire = .TRUE.
CASE ('NES')
S(ib,ifield,igrid)%nested = .TRUE.
CASE ('PER')
S(ib,ifield,igrid)%periodic = .TRUE.
IF ((ib.eq.ieast).or.(ib.eq.iwest)) THEN
EWperiodic(igrid)=.TRUE.
ELSE IF ((ib.eq.inorth).or.(ib.eq.isouth)) THEN
NSperiodic(igrid)=.TRUE.
END IF
CASE ('RAD')
S(ib,ifield,igrid)%radiation = .TRUE.
CASE ('RADNUD')
S(ib,ifield,igrid)%radiation = .TRUE.
S(ib,ifield,igrid)%nudging = .TRUE.
S(ib,ifield,igrid)%acquire = .TRUE.
CASE ('RED')
S(ib,ifield,igrid)%reduced = .TRUE.
CASE ('SHC')
S(ib,ifield,igrid)%Shchepetkin = .TRUE.
S(ib,ifield,igrid)%acquire = .TRUE.
S(ib,isFsur,igrid)%acquire = .TRUE.
CASE DEFAULT
IF (Master) THEN
WRITE (stdout,10) TRIM(Vinp(ib)), TRIM(line)
END IF
exit_flag=2
RETURN
END SELECT
END DO
!
! If processing tracers and last standard input entry (Icont=0), set
! unspecified tracer values to the last tracer entry.
!
IF ((iTrcStr.gt.0).and.(iTrcEnd.gt.0)) THEN
IF ((Icont.eq.0).and.(ifield.lt.isTvar(iTrcEnd))) THEN
DO i=ifield+1,isTvar(iTrcEnd)
DO ib=1,4
S(ib,i,igrid)%clamped = S(ib,ifield,igrid)%clamped
S(ib,i,igrid)%closed = S(ib,ifield,igrid)%closed
S(ib,i,igrid)%gradient = S(ib,ifield,igrid)%gradient
S(ib,i,igrid)%nested = S(ib,ifield,igrid)%nested
S(ib,i,igrid)%periodic = S(ib,ifield,igrid)%periodic
S(ib,i,igrid)%radiation = S(ib,ifield,igrid)%radiation
S(ib,i,igrid)%nudging = S(ib,ifield,igrid)%nudging
S(ib,i,igrid)%acquire = S(ib,ifield,igrid)%acquire
END DO
ic=ic+1
END DO
END IF
END IF
END IF
!
! If appropriate, increase or reset nested grid counter.
!
IF ((Icont.gt.0).and.(Ngrids.gt.1)) THEN
IF ((iTrcStr.gt.0).and.(iTrcEnd.gt.0)) THEN
IF ((ifield.eq.isTvar(iTrcEnd)).or.(ic.gt.1)) THEN
igrid=igrid+MIN(1,Icont)
END IF
ELSE
igrid=igrid+MIN(1,Icont)
END IF
IF (igrid.gt.Ngrids) THEN
IF (Master) THEN
WRITE (stdout,20) TRIM(line)
END IF
exit_flag=2
RETURN
END IF
ELSE
igrid=1
END IF
load_lbc=ic
10 FORMAT (/,' LOAD_LBC - illegal lateral boundary condition ', &
& 'keyword: ',a,/,12x,a)
20 FORMAT (/,' LOAD_LBC - incorrect continuation symbol in line:',/, &
& 12x,a,/,12x,'number of nested grid values exceeded.')
!
RETURN
END FUNCTION load_lbc
!
FUNCTION load_s1d1 (Nval, Fname, Fdim, line, label, igrid, &
& Mgrids, Nfiles, io_type, S)
!
!***********************************************************************
! !
! This function loads input values into requested 1D structure !
! S(Mgrids) containing information about I/O files. !
! !
! On Input: !
! !
! Nval Number of values processed (integer) !
! Fname File name(s) processed (string array) !
! Fdim File name(s) dimension in calling program (integer) !
! line Current input line (string) !
! label I/O structure label (string) !
! igrid Nested grid counter (integer) !
! Mgrids Number of nested grids (integer) !
! Nfiles Number of files per grid (integer array) !
! io_type File I/O type (integer) !
! S(Mgrids) Derived type structure array, TYPE(T_IO) !
! !
! On Output: !
! !
! igrid Updated nested grid counter. !
! S(Mgrids) Updated derived type structure array, TYPE(T_IO). !
! load_s1d_1 Number of output values processed. !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Mgrids, Nval, Fdim, io_type
integer, intent(inout) :: igrid
integer, intent(inout) :: Nfiles(Mgrids)
character (len=*), intent(in) :: line
character (len=256), intent(in) :: Fname(Fdim)
character (len=*), intent(inout) :: label
TYPE(T_IO), intent(inout) :: S(Mgrids)
!
! Local variable declarations.
!
logical :: load, persist
integer :: Icont, Ipipe, i, is, j, lstr, my_Mgrids, ng
integer :: load_s1d1
character (len=1 ), parameter :: blank = ' '
!
!-----------------------------------------------------------------------
! Count files for all grids and activate load switch.
!-----------------------------------------------------------------------
!
! Check current line for the continuation symbol [char(92)=\] or pipe
! symbol [char(124)=|]. The continuation symbol is used to separate
! string values for different grid, whereas the pipe symbol is used
! to separate multi-string values for split input files. User may
! split the records for a particular input field into several files.
!
Icont=INDEX(TRIM(line),CHAR(92) ,BACK=.FALSE.)
Ipipe=INDEX(TRIM(line),CHAR(124),BACK=.FALSE.)
IF ((Icont.eq.0).and.(Ipipe.eq.0)) THEN
load=.TRUE. ! last input string
ELSE
load=.FALSE. ! process next string
END IF
!
! Accumulate number of multi-files per each grid.
!
Nfiles(igrid)=Nfiles(igrid)+1
!
! Set grid counter.
!
IF (.not.load) THEN
igrid=igrid+MIN(1,Icont)
END IF
IF (igrid.gt.Mgrids) THEN
IF (Master) THEN
WRITE (stdout,10) TRIM(line)
END IF
exit_flag=2
RETURN
END IF
!
!-----------------------------------------------------------------------
! Load I/O information into structure.
!-----------------------------------------------------------------------
!
IF (load) THEN
!
! If nesting and the number of file name entries is less than Mgrids,
! persist the last values provided. This is the case when not enough
! entries are provided by "==" plural symbol after the KEYWORD.
!
IF (igrid.lt.Mgrids) THEN
DO i=igrid+1,Mgrids
Nfiles(i)=Nfiles(igrid)
END DO
my_Mgrids=igrid
persist=.TRUE.
ELSE
my_Mgrids=Mgrids
persist=.FALSE.
END IF
!
! Allocate various fields in structure, if not continuation or pipe
! symbol is found which indicates end of input data.
!
IF (label(1:3).eq.'FLT') THEN
is=-6
ELSE
is=1
END IF
!
DO ng=1,Mgrids
allocate ( S(ng)%Nrec(Nfiles(ng)) )
allocate ( S(ng)%time_min(Nfiles(ng)) )
allocate ( S(ng)%time_max(Nfiles(ng)) )
allocate ( S(ng)%Vid(is:NV) )
allocate ( S(ng)%Tid(MT) )
allocate ( S(ng)%files(Nfiles(ng)) )
END DO
!
! Intialize strings to blank to facilitate processing.
!
DO ng=1,Mgrids
lstr=LEN(S(ng)%name)
DO i=1,lstr
S(ng)%head(i:i)=blank
S(ng)%base(i:i)=blank
S(ng)%name(i:i)=blank
END DO
DO j=1,Nfiles(ng)
DO i=1,lstr
S(ng)%files(j)(i:i)=blank
END DO
END DO
END DO
!
! Initialize and load fields into structure.
!
i=0
DO ng=1,my_Mgrids
S(ng)%IOtype=io_type ! file IO type
S(ng)%Nfiles=Nfiles(ng) ! number of multi-files
S(ng)%Fcount=1 ! multi-file counter
S(ng)%load=1 ! filename load counter
S(ng)%Rindex=0 ! time index
S(ng)%ncid=-1 ! closed NetCDF state
S(ng)%Vid=-1 ! NetCDF variables IDs
S(ng)%Tid=-1 ! NetCDF tracers IDs
DO j=1,Nfiles(ng)
i=i+1
S(ng)%files(j)=TRIM(Fname(i)) ! load multi-files
S(ng)%Nrec(j)=0 ! record counter
S(ng)%time_min(j)=0.0_dp ! starting time
S(ng)%time_max(j)=0.0_dp ! ending time
END DO
S(ng)%label=TRIM(label) ! structure label
S(ng)%name=TRIM(S(ng)%files(1)) ! load first file
lstr=LEN_TRIM(S(ng)%name)
S(ng)%head=S(ng)%name(1:lstr-3) ! do not include ".nc"
S(ng)%base=S(ng)%name(1:lstr-3) ! do not include ".nc"
Nfiles(ng)=0 ! clean file counter
END DO
!
! If appropriate, persist last value(s).
!
IF (persist) THEN
DO ng=igrid+1,Mgrids
S(ng)%IOtype=io_type
S(ng)%Nfiles=S(igrid)%Nfiles
S(ng)%Fcount=1
S(ng)%load=1
S(ng)%Rindex=0
S(ng)%ncid=-1
S(ng)%Vid=-1
S(ng)%Tid=-1
DO j=1,S(igrid)%Nfiles
S(ng)%files(j)=S(igrid)%files(j)
S(ng)%Nrec(j)=0
S(ng)%time_min(j)=0.0_dp
S(ng)%time_max(j)=0.0_dp
END DO
S(ng)%label=TRIM(label)
S(ng)%name=S(igrid)%name
S(ng)%base=S(igrid)%base
Nfiles(ng)=0
END DO
END IF
!
! Reset counters and clean label.
!
igrid=1
DO ng=1,Mgrids
Nfiles(ng)=0
END DO
DO i=1,LEN(label)
label(i:i)=blank
END DO
END IF
load_s1d1=Nval
10 FORMAT (/,' LOAD_S1D1 - incorrect continuation symbol in line:', &
& /,14x,a,/,11x,'number of nested grid values exceeded.')
!
RETURN
END FUNCTION load_s1d1
!
FUNCTION load_s1d2 (Nval, Fname, Fdim, line, label, igrid, &
& Mgrids, Nfiles, idim, Ie, io_type, S)
!
!***********************************************************************
! !
! This function loads input values into requested 2D structure !
! S(Ie,:) elemement containing information about I/O files. !
! !
! On Input: !
! !
! Nval Number of values processed (integer) !
! Fname File name(s) processed (string array) !
! Fdim File name(s) dimension in calling program (integer) !
! line Current input line (string) !
! label I/O structure label (string) !
! igrid Nested grid counter (integer) !
! Mgrids Number of nested grids (integer) !
! Nfiles Number of files per grid (integer array) !
! idim Size of structure inner dimension (integer) !
! Ie Inner dimension element to process (integer) !
! io_type File I/O type (integer) !
! S(Ie,Mgrids) Derived type structure array, TYPE(T_IO) !
! !
! On Output: !
! !
! igrid Updated nested grid counter. !
! S(Ie,Mgrids) Updated derived type structure array, TYPE(T_IO). !
! load_s1d_2 Number of output values processed. !
! !
!***********************************************************************
!
USE mod_param
USE mod_parallel
USE mod_iounits
USE mod_ncparam
USE mod_scalars
!
! Imported variable declarations.
!
integer, intent(in) :: Mgrids, Nval, Fdim, Ie, idim, io_type
integer, intent(inout) :: igrid
integer, intent(inout) :: Nfiles(Mgrids)
character (len=*), intent(in) :: line
character (len=256), intent(in) :: Fname(Fdim)
character (len=*), intent(inout) :: label
TYPE(T_IO), intent(inout) :: S(idim,Mgrids)
!
! Local variable declarations.
!
logical :: load, persist
integer :: Icont, Ipipe, i, is, j, lstr, my_Mgrids, ng
integer :: load_s1d2
character (len=1 ), parameter :: blank = ' '
!
!-----------------------------------------------------------------------
! Count files for all grids and activate load switch.
!-----------------------------------------------------------------------
!
! Check current line for the continuation symbol [char(92)=\] or pipe
! symbol [char(124)=|]. The continuation symbol is used to separate
! string values for different grid, whereas the pipe symbol is used
! to separate multi-string values for split input files. User may
! split the records for a particular input field into several files.
!
Icont=INDEX(TRIM(line),CHAR(92) ,BACK=.FALSE.)
Ipipe=INDEX(TRIM(line),CHAR(124),BACK=.FALSE.)
IF ((Icont.eq.0).and.(Ipipe.eq.0)) THEN
load=.TRUE. ! last input string
ELSE
load=.FALSE. ! process next string
END IF
!
! Accumulate number of multi-files per each grid.
!
Nfiles(igrid)=Nfiles(igrid)+1
!
! Set grid counter.
!
IF (.not.load) THEN
igrid=igrid+MIN(1,Icont)
END IF
IF (igrid.gt.Mgrids) THEN
IF (Master) THEN
WRITE (stdout,10) TRIM(line)
END IF
exit_flag=2
RETURN
END IF
!
!-----------------------------------------------------------------------
! Load I/O information into structure.
!-----------------------------------------------------------------------
!
IF (load) THEN
!
! If nesting and the number of file name entries is less than Mgrids,
! persist the last values provided. This is the case when not enough
! entries are provided by "==" plural symbol after the KEYWORD.
!
IF (igrid.lt.Mgrids) THEN
DO i=igrid+1,Mgrids
Nfiles(i)=Nfiles(igrid)
END DO
my_Mgrids=igrid
persist=.TRUE.
ELSE
my_Mgrids=Mgrids
persist=.FALSE.
END IF
!
! Allocate various fields in structure, if not continuation or pipe
! symbol is found which indicates end of input data.
!
DO ng=1,Mgrids
allocate ( S(Ie,ng)%Nrec(Nfiles(ng)) )
allocate ( S(Ie,ng)%time_min(Nfiles(ng)) )
allocate ( S(Ie,ng)%time_max(Nfiles(ng)) )
allocate ( S(Ie,ng)%Vid(NV) )
allocate ( S(Ie,ng)%Tid(MT) )
allocate ( S(Ie,ng)%files(Nfiles(ng)) )
END DO
!
! Intialize strings to blank to facilitate processing.
!
DO ng=1,Mgrids
lstr=LEN(S(Ie,ng)%name)
DO i=1,lstr
S(Ie,ng)%head(i:i)=blank
S(Ie,ng)%base(i:i)=blank
S(Ie,ng)%name(i:i)=blank
END DO
DO j=1,Nfiles(ng)
DO i=1,lstr
S(Ie,ng)%files(j)(i:i)=blank
END DO
END DO
END DO
!
! Initialize and load fields into structure.
!
i=0
DO ng=1,my_Mgrids
S(Ie,ng)%IOtype=io_type ! file IO type
S(Ie,ng)%Nfiles=Nfiles(ng) ! number of multi-files
S(Ie,ng)%Fcount=1 ! multi-file counter
S(Ie,ng)%load=1 ! filename load counter
S(Ie,ng)%Rindex=0 ! time index
S(Ie,ng)%ncid=-1 ! closed NetCDF state
S(Ie,ng)%Vid=-1 ! NetCDF variables IDs
S(Ie,ng)%Tid=-1 ! NetCDF tracers IDs
DO j=1,Nfiles(ng)
i=i+1
S(Ie,ng)%files(j)=TRIM(Fname(i)) ! load multi-files
S(Ie,ng)%Nrec(j)=0 ! record counter
S(Ie,ng)%time_min(j)=0.0_dp ! starting time
S(Ie,ng)%time_max(j)=0.0_dp ! ending time
END DO
S(Ie,ng)%label=TRIM(label) ! structure label
S(Ie,ng)%name=TRIM(S(Ie,ng)%files(1)) ! load first file
lstr=LEN_TRIM(S(Ie,ng)%name)
S(Ie,ng)%head=S(Ie,ng)%name(1:lstr-3) ! do not include ".nc"
S(Ie,ng)%base=S(Ie,ng)%name(1:lstr-3) ! do not include ".nc"
Nfiles(ng)=0 ! clean file counter
END DO
!
! If appropriate, persist last value(s).
!
IF (persist) THEN
DO ng=igrid+1,Mgrids
S(Ie,ng)%IOtype=io_type
S(Ie,ng)%Nfiles=S(Ie,igrid)%Nfiles
S(Ie,ng)%Fcount=1
S(Ie,ng)%load=1
S(Ie,ng)%Rindex=0
S(Ie,ng)%ncid=-1
S(Ie,ng)%Vid=-1
S(Ie,ng)%Tid=-1
DO j=1,S(Ie,igrid)%Nfiles
S(Ie,ng)%files(j)=S(Ie,igrid)%files(j)
S(Ie,ng)%Nrec(j)=0
S(Ie,ng)%time_min(j)=0.0_dp
S(Ie,ng)%time_max(j)=0.0_dp
END DO
S(Ie,ng)%label=TRIM(label)
S(Ie,ng)%name=S(Ie,igrid)%name
S(Ie,ng)%base=S(Ie,igrid)%base
Nfiles(ng)=0
END DO
END IF
!
! Reset counters and clean label.
!
igrid=1
DO ng=1,Mgrids
Nfiles(ng)=0
END DO
DO i=1,LEN(label)
label(i:i)=blank
END DO
END IF
load_s1d2=Nval
10 FORMAT (/,' LOAD_S1D2 - incorrect continuation symbol in line:', &
& /,14x,a,/,11x,'number of nested grid values exceeded.')
!
RETURN
END FUNCTION load_s1d2
!
FUNCTION load_s2d (Nval, Fname, Fdim, line, label, ifile, igrid, &
& Mgrids, Nfiles, Ncount, idim, io_type, S)
!
!***********************************************************************
! !
! This function loads input values into requested 2D structure !
! containing information about input forcing files. Notice that !
! Mgrids is passed for flexibility in coupling algorithms. !
! !
! On Input: !
! !
! Nval Number of values processed (integer) !
! Fname File name(s) processed (string array) !
! Fdim File name(s) dimension in calling program (integer) !
! line Current input line (string) !
! label I/O structure label (string) !
! ifile File structure counter (integer) !
! igrid Nested grid counter (integer) !
! Mgrids Number of nested grids (integer) !
! Nfiles Number of input files per grid (integer vector) !
! Ncount Number of files per grid counter (integer array) !
! idim Size of structure inner dimension (integer) !
! io_type File I/O type (integer) !
! S Derived type structure, TYPE(T_IO) !
! !
! On Output: !
! !
! ifile Updated file counter. !
! igrid Updated nested grid counter. !
! S Updated derived type structure, TYPE(T_IO). !
! load_s2d Number of output values processed. !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Mgrids, Nval, Fdim, idim, io_type
integer, intent(in) :: Nfiles(Mgrids)
integer, intent(inout) :: ifile, igrid
integer, intent(inout) :: Ncount(idim,Mgrids)
!
character (len=*), intent(in) :: line
character (len=256), intent(in) :: Fname(Fdim)
character (len=*), intent(inout) :: label
!
TYPE(T_IO), intent(inout) :: S(idim,Mgrids)
!
! Local variable declarations.
!
logical :: load, persist
!
integer :: Icont, Ipipe, i, is, j, k, lstr, my_Mgrids, ng
integer :: load_s2d
!
character (len=1 ), parameter :: blank = ' '
!
!-----------------------------------------------------------------------
! Count files for all grids and activate load switch.
!-----------------------------------------------------------------------
!
! Check current line for the continuation symbol [char(92)=\] or pipe
! symbol [char(124)=|]. The continuation symbol is used to separate
! string values for different grid, whereas the pipe symbol is used
! to separate multi-string values for split input files. User may
! split the records for a particular input field into several files.
!
Icont=INDEX(TRIM(line),CHAR(92) ,BACK=.FALSE.)
Ipipe=INDEX(TRIM(line),CHAR(124),BACK=.FALSE.)
IF ((Icont.eq.0).and.(Ipipe.eq.0)) THEN
load=.TRUE. ! last input string
ELSE
load=.FALSE. ! process next string
END IF
!
! Accumulate number of multi-files per each grid.
!
Ncount(ifile,igrid)=Ncount(ifile,igrid)+1
!
! Set counters for next processing file, if any. The continuation
! symbol in the input "line" is used to advance the counters.
!
IF (.not.load) THEN
IF ((ifile.lt.Nfiles(igrid)).or.(Ipipe.ne.0)) THEN
ifile=ifile+MIN(1,Icont)
ELSE
ifile=1
igrid=igrid+MIN(1,Icont)
END IF
END IF
IF (ifile.gt.idim) THEN
IF (Master) THEN
WRITE (stdout,10) TRIM(line)
END IF
exit_flag=2
RETURN
END IF
IF (igrid.gt.Mgrids) THEN
IF (Master) THEN
WRITE (stdout,20) TRIM(line)
END IF
exit_flag=2
RETURN
END IF
!
!-----------------------------------------------------------------------
! Load I/O information into structure.
!-----------------------------------------------------------------------
!
IF (load) THEN
!
! If nesting and the number of file name entries is less than Mgrids,
! persist the last values provided. This is the case when not enough
! entries are provided by "==" plural symbol after the KEYWORD.
!
IF (igrid.lt.Mgrids) THEN
DO j=igrid+1,Mgrids
DO i=1,idim
Ncount(i,j)=Ncount(i,igrid)
END DO
END DO
my_Mgrids=igrid
persist=.TRUE.
ELSE
my_Mgrids=Mgrids
persist=.FALSE.
END IF
!
! Allocate various fields in structure, if not continuation or pipe
! symbol is found which indicates end of input data.
!
DO ng=1,Mgrids
DO i=1,idim
allocate ( S(i,ng)%Nrec(Ncount(i,ng)) )
allocate ( S(i,ng)%time_min(Ncount(i,ng)) )
allocate ( S(i,ng)%time_max(Ncount(i,ng)) )
allocate ( S(i,ng)%Vid(NV) )
allocate ( S(i,ng)%Tid(MT) )
allocate ( S(i,ng)%files(Ncount(i,ng)) )
END DO
END DO
!
! Intialize strings to blank to facilitate processing.
!
DO ng=1,Mgrids
DO i=1,idim
lstr=LEN(S(i,ng)%name)
DO j=1,lstr
S(i,ng)%head(j:j)=blank
S(i,ng)%base(j:j)=blank
S(i,ng)%name(j:j)=blank
END DO
DO k=1,Ncount(i,ng)
DO j=1,lstr
S(i,ng)%files(k)(j:j)=blank
END DO
END DO
END DO
END DO
!
! Initialize and load fields into structure.
!
k=0
DO ng=1,my_Mgrids
DO i=1,Nfiles(ng)
S(i,ng)%IOtype=io_type ! file IO type
S(i,ng)%Nfiles=Ncount(i,ng) ! number of multi-files
S(i,ng)%Fcount=1 ! multi-file counter
S(i,ng)%load=1 ! filename load counter
S(i,ng)%Rindex=0 ! time index
S(i,ng)%ncid=-1 ! closed NetCDF state
S(i,ng)%Vid=-1 ! NetCDF variables IDs
S(i,ng)%Tid=-1 ! NetCDF tracers IDs
DO j=1,Ncount(i,ng)
k=k+1
S(i,ng)%files(j)=TRIM(Fname(k)) ! load multi-files
S(i,ng)%Nrec(j)=0 ! record counter
S(i,ng)%time_min(j)=0.0_dp ! starting time
S(i,ng)%time_max(j)=0.0_dp ! ending time
END DO
S(i,ng)%label=TRIM(label) ! structure label
S(i,ng)%name=TRIM(S(i,ng)%files(1)) ! load first file
lstr=LEN_TRIM(S(i,ng)%name)
S(i,ng)%head=S(i,ng)%name(1:lstr-3) ! do not include ".nc"
S(i,ng)%base=S(i,ng)%name(1:lstr-3) ! do not include ".nc"
END DO
END DO
!
! If appropriate, persist last value(s).
!
IF (persist) THEN
DO ng=igrid+1,Mgrids
DO i=1,Nfiles(ng)
S(i,ng)%IOtype=io_type
S(i,ng)%Nfiles=S(i,igrid)%Nfiles
S(i,ng)%Fcount=1
S(i,ng)%load=1
S(i,ng)%Rindex=0
S(i,ng)%ncid=-1
S(i,ng)%Vid=-1
S(i,ng)%Tid=-1
DO j=1,S(i,igrid)%Nfiles
S(i,ng)%files(j)=S(i,igrid)%files(j)
S(i,ng)%Nrec(j)=0
S(i,ng)%time_min(j)=0.0_dp
S(i,ng)%time_max(j)=0.0_dp
END DO
S(i,ng)%label=TRIM(label)
S(i,ng)%head=S(i,igrid)%head
S(i,ng)%base=S(i,igrid)%base
S(i,ng)%name=S(i,igrid)%name
Ncount(i,ng)=0
END DO
END DO
END IF
!
! Reset counters and clean label.
!
igrid=1
ifile=1
DO ng=1,Mgrids
DO i=1,idim
Ncount(i,ng)=0
END DO
END DO
DO i=1,LEN(label)
label(i:i)=blank
END DO
END IF
load_s2d=Nval
10 FORMAT (/,' LOAD_S2D - incorrect continuation symbol in line:',/, &
& 12x,a,/,12x,'inner dimension of structure exceeded.')
20 FORMAT (/,' LOAD_S2D - incorrect continuation symbol in line:',/, &
& 12x,a,/,12x,'number of nested grid values exceeded.')
!
RETURN
END FUNCTION load_s2d
!
FUNCTION load_tadv (Ninp, Vinp, line, nline, itrc, igrid, &
& itracer, iTrcStr, iTrcEnd, svname, S)
!
!***********************************************************************
! !
! This function sets tracers advection logical switches according to !
! input string keywords. !
! !
! On Input: !
! !
! Ninp Size of input variable (integer) !
! Vinp Input values (string) !
! line Current input line (string) !
! nline Multi-line counter (integer) !
! itrc Tracer array index (integer) !
! itracer Calling routine tracer counter (integer) !
! igrid Nested grid counter (integer) !
! iTrcStr Starting tracer index to process (integer) !
! iTrcEnd Ending tracer index to process (integer) !
! svname State variable name (string) !
! S Derived type structure, TYPE(T_ADV) !
! !
! On Output: !
! !
! nline Updated multi-line counter (integer) !
! itracer Updated calling routine tracer counter (integer) !
! igrid Updated nested grid counter (integer) !
! S Updated derived type structure, TYPE(T_LBC) !
! load_tadv Number of output values processed. !
! !
!***********************************************************************
!
! Imported variable declarations.
!
integer, intent(in) :: Ninp, itrc, iTrcStr, iTrcEnd
integer, intent(inout) :: igrid, itracer, nline
character (len=256), intent(in) :: line
character (len=256), intent(in) :: Vinp(Ninp)
character (len=* ), intent(in) :: svname
TYPE(T_ADV), intent(inout) :: S(MAXVAL(NT),Ngrids)
!
! Local variable declarations.
!
integer :: Icont, i, ic
integer :: load_tadv
character (len=10) :: Astring, string
!
!-----------------------------------------------------------------------
! Set tracers advection switches in structure.
!-----------------------------------------------------------------------
!
! Check current line for the continuation symbol [char(92)=\].
!
Icont=INDEX(TRIM(line),CHAR(92) ,BACK=.FALSE.)
!
! Extract tracer advection scheme keywords from Vinp. Notice that
! additional array elements are added to Vinp during continuation
! lines.
!
i=nline
Astring=TRIM(Vinp(i+1))
!
! Advance or reset entry lines counter.
!
IF (Icont.gt.0) THEN
nline=nline+1
ELSE
nline=0
END IF
!
! Set advection switches for each tracer.
!
ic=1
IF ((0.lt.itrc).and.(itrc.le.iTrcEnd)) THEN
string=uppercase(Astring)
SELECT CASE (TRIM(string))
CASE ('A4', 'AKIMA4')
S(itrc,igrid) % AKIMA4 = .TRUE.
CASE ('C2', 'CENTERED2')
S(itrc,igrid) % CENTERED2 = .TRUE.
CASE ('C4', 'CENTERED4')
S(itrc,igrid) % CENTERED4 = .TRUE.
CASE ('HS', 'HSIMT')
S(itrc,igrid) % HSIMT = .TRUE.
CASE ('MP', 'MPDATA')
S(itrc,igrid) % MPDATA = .TRUE.
CASE ('SP', 'SPLINES')
S(itrc,igrid) % SPLINES = .TRUE.
CASE ('SU', 'SU3', 'SPLIT_U3')
S(itrc,igrid) % SPLIT_U3 = .TRUE.
CASE ('U3', 'UPSTREAM3')
S(itrc,igrid) % UPSTREAM3 = .TRUE.
CASE DEFAULT
IF (Master) THEN
WRITE (stdout,10) TRIM(Astring)
END IF
exit_flag=2
RETURN
END SELECT
!
! If processing tracers and last standard input entry (Icont=0), set
! unspecified tracer values to the last tracer entry.
!
IF ((iTrcStr.gt.0).and.(iTrcEnd.gt.0)) THEN
IF ((Icont.eq.0).and.(itracer.lt.iTrcEnd)) THEN
DO i=itrc+1,iTrcEnd
S(i,igrid) % AKIMA4 = S(itrc,igrid) % AKIMA4
S(i,igrid) % CENTERED2 = S(itrc,igrid) % CENTERED2
S(i,igrid) % CENTERED4 = S(itrc,igrid) % CENTERED4
S(i,igrid) % HSIMT = S(itrc,igrid) % HSIMT
S(i,igrid) % MPDATA = S(itrc,igrid) % MPDATA
S(i,igrid) % SPLINES = S(itrc,igrid) % SPLINES
S(i,igrid) % SPLIT_U3 = S(itrc,igrid) % SPLIT_U3
S(i,igrid) % UPSTREAM3 = S(itrc,igrid) % UPSTREAM3
END DO
ic=ic+1
END IF
END IF
END IF
!
! If appropriate, reset tracer grid counter. It is done to process
! other keywords using this function.
!
IF ((itrc.eq.iTrcEnd).or.(ic.gt.1)) THEN
itracer=0
END IF
!
! If appropriate, increase or reset nested grid counter.
!
IF ((Icont.gt.0).and.(Ngrids.gt.1)) THEN
IF ((iTrcStr.gt.0).and.(iTrcEnd.gt.0)) THEN
IF ((itrc.eq.iTrcEnd).or.(ic.gt.1)) THEN
igrid=igrid+MIN(1,Icont)
END IF
ELSE
igrid=igrid+MIN(1,Icont)
END IF
IF (igrid.gt.Ngrids) THEN
IF (Master) THEN
WRITE (stdout,20) TRIM(line)
END IF
exit_flag=2
RETURN
END IF
ELSE
igrid=1
END IF
load_tadv=ic
10 FORMAT (/,' LOAD_TADV - illegal tracer advection scheme ', &
& 'keyword: ',a,/,13x,'Correct standard input file.',/)
20 FORMAT (/,' LOAD_TADV - incorrect continuation symbol in line:', &
& /,13x,a,/,13x,'number of nested grid values exceeded.')
!
RETURN
END FUNCTION load_tadv
!
END MODULE inp_decode_mod