!----------------------------------------------------------------------- subroutine handle_ncerr(istat,msg) implicit none #include ! ! Handle a netcdf lib error: ! integer,intent(in) :: istat character(len=*),intent(in) :: msg ! write(6,"(/72('-'))") write(6,"('>>> Error from netcdf library:')") write(6,"(a)") trim(msg) write(6,"('istat=',i5)") istat write(6,"(a)") nf_strerror(istat) write(6,"(72('-')/)") return end subroutine handle_ncerr !----------------------------------------------------------------------- subroutine fprint8(hdr,idim,f1,f2,f3,f4,f5,f6,f7,f8, | n1,n2,n3,n4,n5,n6,n7,n8) implicit none ! ! Args: character(len=*),intent(in) :: hdr integer,intent(in) :: idim real,dimension(idim),intent(in) :: f1,f2,f3,f4,f5,f6,f7,f8 character(len=*),intent(in) :: n1,n2,n3,n4,n5,n6,n7,n8 ! ! Local: integer :: i ! character(len=16) :: format='(e12.4) ' character(len=16) :: format='(1pe12.4) ' ! write(6,"(/)") ! if (len_trim(hdr) > 0) write(6,"('fprint8 idim=',i4,': ',a)") ! | idim,trim(hdr) if (len_trim(hdr) > 0) write(6,"(a)") trim(hdr) write(6,"(4x)",advance='no') if (len_trim(n1) > 0) write(6,"(a12)",advance='no') trim(n1) if (len_trim(n2) > 0) write(6,"(a12)",advance='no') trim(n2) if (len_trim(n3) > 0) write(6,"(a12)",advance='no') trim(n3) if (len_trim(n4) > 0) write(6,"(a12)",advance='no') trim(n4) if (len_trim(n5) > 0) write(6,"(a12)",advance='no') trim(n5) if (len_trim(n6) > 0) write(6,"(a12)",advance='no') trim(n6) if (len_trim(n7) > 0) write(6,"(a12)",advance='no') trim(n7) if (len_trim(n8) > 0) write(6,"(a12)",advance='no') trim(n8) write(6,"(' ')") do i=1,idim write(6,"(i4)",advance='no') i if (len_trim(n1) > 0) write(6,format,advance='no') f1(i) if (len_trim(n2) > 0) write(6,format,advance='no') f2(i) if (len_trim(n3) > 0) write(6,format,advance='no') f3(i) if (len_trim(n4) > 0) write(6,format,advance='no') f4(i) if (len_trim(n5) > 0) write(6,format,advance='no') f5(i) if (len_trim(n6) > 0) write(6,format,advance='no') f6(i) if (len_trim(n7) > 0) write(6,format,advance='no') f7(i) if (len_trim(n8) > 0) write(6,format,advance='no') f8(i) write(6,"(' ')") enddo ! write(6,"('End fprint8: ',a)") trim(hdr) end subroutine fprint8 !----------------------------------------------------------------------- subroutine fprint6(hdr,idim,f1,f2,f3,f4,f5,f6, | n1,n2,n3,n4,n5,n6) implicit none ! ! Args: character(len=*),intent(in) :: hdr integer,intent(in) :: idim real,dimension(idim),intent(in) :: f1,f2,f3,f4,f5,f6 character(len=*),intent(in) :: n1,n2,n3,n4,n5,n6 ! ! Local: integer :: i ! write(6,"(/)") if (len_trim(hdr) > 0) write(6,"(a)") trim(hdr) write(6,"(4x)",advance='no') if (len_trim(n1) > 0) write(6,"(a12)",advance='no') trim(n1) if (len_trim(n2) > 0) write(6,"(a12)",advance='no') trim(n2) if (len_trim(n3) > 0) write(6,"(a12)",advance='no') trim(n3) if (len_trim(n4) > 0) write(6,"(a12)",advance='no') trim(n4) if (len_trim(n5) > 0) write(6,"(a12)",advance='no') trim(n5) if (len_trim(n6) > 0) write(6,"(a12)",advance='no') trim(n6) write(6,"(' ')") do i=1,idim write(6,"(i4)",advance='no') i if (len_trim(n1) > 0) write(6,"(e12.4)",advance='no') f1(i) if (len_trim(n2) > 0) write(6,"(e12.4)",advance='no') f2(i) if (len_trim(n3) > 0) write(6,"(e12.4)",advance='no') f3(i) if (len_trim(n4) > 0) write(6,"(e12.4)",advance='no') f4(i) if (len_trim(n5) > 0) write(6,"(e12.4)",advance='no') f5(i) if (len_trim(n6) > 0) write(6,"(e12.4)",advance='no') f6(i) write(6,"(' ')") enddo end subroutine fprint6 !----------------------------------------------------------------------- subroutine check_nans(f,id1,id2,id3,name,n_total,ispval,spval, | iprint,ifatal) ! ! Check for existence of +/-INF and NaN's in field f(id1,id2,id3). ! If ispval > 0 -> replace any INF or NaNs with spval ! If iprint==1 -> print warnings only if INF or NaNs are found ! If iprint==2 -> always print number of INF and NaNs found ! If ifatal > 0 -> stop program when first INF or NaNs are found ! Note: Can distinguish between +/-INF (not really NaNs), but cannot ! distinguish between types of actual NaNs (+/-NaNQ and NaNS). ! IBM only. See pp318-319 User's Guide Version 8 XL Fortran for AIX ! implicit none ! ! Args: integer,intent(in) :: id1,id2,id3,iprint,ifatal,ispval integer,intent(out) :: n_total ! total number of +/-INF+NaNs real,intent(inout) :: f(id1,id2,id3) real,intent(in) :: spval character(len=*),intent(in) :: name ! ! Local: real :: plus_inf,minus_inf,plus_nanq,minus_nanq,sig_nan ! ! For double precision 8-byte reals (-qrealsize=8): data plus_inf /z'7ff0000000000000'/ ! INF (overflow) data minus_inf /z'fff0000000000000'/ ! -INF (underflow) data plus_nanq /z'7ff8000000000000'/ ! NaNQ (plus quiet NaN) data minus_nanq /z'fff8000000000000'/ ! -NaNQ (minus quiet NaN) data sig_nan /z'7ff0000000000001'/ ! NaNS (signalling NaN) ! ! For single precision (4-byte) reals: ! data plus_inf /z'7f800000'/ ! INF (overflow) ! data minus_inf /z'ff800000'/ ! -INF (underflow) ! data plus_nanq /z'7fc00000'/ ! NaNQ (plus quiet NaN) ! data minus_nanq /z'ffc00000'/ ! -NaNQ (minus quiet NaN) ! data sig_nan /z'7f800001'/ ! NaNS (signalling NaN) ! integer :: i1,i2,i3 integer :: | n_plus_inf, ! number of INF | n_minus_inf, ! number of -INF | n_nan ! total number of NaNs (+/-NaNQ and NaNS) ! ! Init: n_plus_inf = 0 n_minus_inf = 0 n_nan = 0 n_total = 0 ! ! Scan array: do i3=1,id3 do i2=1,id2 ! ! +/-INF are detected by simple comparison: n_plus_inf = n_plus_inf + count(f(:,i2,i3)==plus_inf) n_minus_inf = n_minus_inf + count(f(:,i2,i3)==minus_inf) ! ! NaNs (NaNQ or NaNS) are detected by (a /= a): n_nan = n_nan + count(f(:,i2,i3)/=f(:,i2,i3)) n_total = n_plus_inf+n_minus_inf+n_nan ! ! write(6,"('i3=',i3,' i2=',i3,' n_plus_inf=',i8,' n_minus_inf=' ! | ,i8,' n_nan=',i8,' n_total=',i8)") i3,i2,n_plus_inf, ! | n_minus_inf,n_nan,n_total ! ! Fatal when first INF or NaN is found: if (ifatal > 0 .and. n_total > 0) then write(6,"(/,'>>> FATAL: Found INF and/or NaNs in field ', | a)") name write(6,"(' Dimensions id1,id2,id3=',3i4)") id1,id2,id3 write(6,"(' First INF or NaN found at id2=',i4,', id3=', | i4)") i2,i3 write(6,"(' n_plus_inf = ',i6)") n_plus_inf write(6,"(' n_minus_inf = ',i6)") n_minus_inf write(6,"(' n_nan (NaNS or NaNQ) = ',i6)") n_nan write(6,"(' data(:,',i3,',',i3,') = ',/,(6e12.4))") | i2,i3,f(:,i2,i3) call shutdown('check_nans') endif ! ifatal > 0 ! ! Replace any INF or NaNs with spval: if (ispval > 0 .and. n_total > 0) then do i1=1,id1 if (f(i1,i2,i3)==plus_inf.or.f(i1,i2,i3)==minus_inf.or. | f(i1,i2,i3)/=f(i1,i2,i3)) f(i1,i2,i3) = spval enddo endif enddo ! i2=1,id2 enddo ! i3=1,id3 ! ! Print level 1 (print warnings only if INF or NaNs are found): if (iprint==1) then if (n_plus_inf > 0) write(6,"('>>> WARNING: found ', | i6,' INF values in field ',a,' (id1,2,3=',3i4,')')") | n_plus_inf,name,id1,id2,id3 if (n_minus_inf > 0) write(6,"('>>> WARNING: found ', | i6,' -INF values in field ',a,' (id1,2,3=',3i4,')')") | n_minus_inf,name,id1,id2,id3 if (n_nan > 0) write(6,"('>>> WARNING: found ',i6, | ' NaNS or NaNQ values in field ',a,' (id1,2,3=',3i4,')')") | n_nan,name,id1,id2,id3 ! if (ispval > 0 .and. n_total > 0) ! | write(6,"('>>> Replaced ',i8,' values with spval ',e12.4)") ! | n_total,spval ! ! Print level 2 (always print number of nans found): elseif (iprint==2) then write(6,"('Checking for INF and NaNs in field ',a,' id1,2,3=', | 3i4)") name,id1,id2,id3 print *,' n_plus_inf (',plus_inf, ') = ',n_plus_inf print *,' n_minus_inf (',minus_inf, ') = ',n_minus_inf print *,' n_nan (',plus_nanq,'+',sig_nan,') = ',n_nan print *,' n_total (total INF+NaNs) = ',n_total ! if (ispval > 0) ! | print *,' Replaced ',n_total,' values with spval ',spval endif end subroutine check_nans !----------------------------------------------------------------------- subroutine shutdown(msg) ! ! An fatal error has occurred -- shut down the model. ! implicit none ! ! Args: character(len=*) :: msg ! write(6,"(/,28('>'),' MODEL SHUTDOWN ',28('<'))") write(6,"('Shutdown: stop message: ',a)") trim(msg) stop end subroutine shutdown !------------------------------------------------------------------- subroutine datetime(curdate,curtime) ! ! Return character*8 values for current date and time. ! (sub date_and_time is an f90 intrinsic) ! implicit none ! ! Args: character(len=*),intent(out) :: curdate,curtime ! ! Local: character(len=8) :: date character(len=10) :: time character(len=5) :: zone integer :: values(8) ! curdate = ' ' curtime = ' ' call date_and_time(date,time,zone,values) ! ! write(6,"('datetime: date=',a,' time=',a,' zone=',a)") ! | date,time,zone ! write(6,"('datetime: values=',8i8)") values ! curdate(1:2) = date(5:6) curdate(3:3) = '/' curdate(4:5) = date(7:8) curdate(6:6) = '/' curdate(7:8) = date(3:4) ! curtime(1:2) = time(1:2) curtime(3:3) = ':' curtime(4:5) = time(3:4) curtime(6:6) = ':' curtime(7:8) = time(5:6) ! end subroutine datetime !------------------------------------------------------------------- subroutine setosys(system) implicit none character(len=*),intent(out) :: system ! system = ' ' #ifdef UNICOS system = 'UNICOS' #elif IRIX system = 'IRIX' #elif AIX system = 'AIX' #elif OSF1 system = 'OSF1' #elif SUN system = 'SUN' #elif LINUX system = 'LINUX' #else write(6,"('>>> WARNING setosys: unresolved OS cpp directive.')") system = 'unknown' #endif end subroutine setosys !------------------------------------------------------------------- subroutine print_field(f,msg) use fields ! field typedef implicit none type(field),intent(in) :: f character(len=*),intent(in) :: msg write(6,"(/,'print_field: ',a)") trim(msg) write(6,"(' var_name =',a,' short_name=',a)") | trim(f%var_name),trim(f%short_name) if (associated(f%data)) then write(6,"(' data=',/,(6e12.4))") f%data else write(6,"(' [data not allocated]')") endif end subroutine print_field !------------------------------------------------------------------- subroutine print_fhist(vname,fhist,nfhist,msg) use fields implicit none ! ! Args: integer,intent(in) :: nfhist type(field),intent(in) :: fhist(nfhist) character(len=*),intent(in) :: vname,msg ! integer :: i,iv iv = 0 do i=1,nfhist if (trim(vname)==trim(fhist(i)%var_name)) iv = i enddo if (iv==0) then write(6,"('print_fhist: vname ',a,' not found in fhist.', | ' (msg=',a,')')") vname,trim(msg) return endif write(6,"(/,'print_fhist: ',a)") trim(msg) write(6,"(' iv=',i4,' var_name =',a,' short_name=',a)") | iv,trim(fhist(iv)%var_name),trim(fhist(iv)%short_name) if (associated(fhist(iv)%data)) then write(6,"(' data=',/,(6e12.4))") fhist(iv)%data else write(6,"(' [data not allocated]')") endif end subroutine print_fhist !------------------------------------------------------------------- subroutine print_ftable(flds,nf,fclass) ! ! Print components of a field group (class): ! use fields ! field typedef implicit none ! ! Args: integer,intent(in) :: nf type(field),intent(in) :: flds(nf) character(len=*),intent(in) :: fclass ! ! Local: integer :: i character(len=3) :: timedep ! ! One line for each field: write(6,"(/, | '============================== Field Class: ',a, | ' ==============================')") fclass write(6,"(' I', | ' Class ', | 'Short Name ', | 'Long Name ', | 'Var Name ', | 'Units ', | 'Time-Dep'/)") do i=1,nf timedep = 'no' if (trim(flds(i)%timedep)=="time-dependent") timedep = 'yes' write(6,"(i3,' ',a,a,a,' ',a,a,a)") i,flds(i)%class(1:8), | flds(i)%short_name(1:12),flds(i)%long_name(1:24), | flds(i)%var_name(1:12),flds(i)%units,timedep enddo ! i=1,nf write(6,"(82('='))") end subroutine print_ftable !----------------------------------------------------------------------- subroutine print_fmods use flds_airglow use flds_atmos use flds_col use flds_dissoc use flds_fields use flds_heat use flds_ionatm use flds_ionzrt use flds_prodloss use flds_ratecoef use flds_sodium use flds_msisatm use flds_modelz use flds_hist ! fhist.F implicit none ! ! Sub print_ftable is in util.F: ! call print_ftable(f_airglow ,nf_airglow ,'airglow ') call print_ftable(f_atmos ,nf_atmos ,'atmosp ') call print_ftable(f_col ,nf_col ,'collll ') call print_ftable(f_dissoc ,nf_dissoc ,'dissoc ') call print_ftable(f_fields ,nf_fields ,'fields ') call print_ftable(f_heat ,nf_heat ,'heat ') call print_ftable(f_totheat ,nf_totheat ,'totheat ') call print_ftable(f_ionatm ,nf_ionatm ,'ionatm ') call print_ftable(f_ionzrt ,nf_ionzrt ,'ionzrt ') call print_ftable(f_prodloss,nf_prodloss,'prodloss') call print_ftable(f_ratecoef,nf_ratecoef,'ratecoef') call print_ftable(f_sodium ,nf_sodium ,'sodium ') call print_ftable(f_msisatm ,nf_msisatm ,'msisatm ') call print_ftable(f_modelz ,nf_modelz ,'modelz ') call print_ftable(f_hist ,nf_hist ,'history ') end subroutine print_fmods C**************************************************************************** C* * C* FUNCTION A18LIN * C* * C**************************************************************************** C C linear interpolation C C called by cco2gr C calls nothing C C input: C X - argument for which a value of function should be found C XN(N),YN(N) - values of function YN(N) at XN(N) grid. X(N) should be C ordered so that X(I-1) < X(I). C output: C A18LIN - value of function for X real FUNCTION A18LIN(X,XN,YN,M,N) ! ! Args: integer,intent(in) :: m,n real,intent(in) :: x,XN(N),YN(N) ! ! Local: integer :: k,i k=m-1 do 1 i=m,n k=k+1 if(x-xn(i)) 2,2,1 1 continue 2 if(k.eq.1) k=2 c k has been found so that xn(k).le.x.lt.xn(k+1) A18LIN=(yn(k)-yn(k-1))/(xn(k)-xn(k-1))*(x-xn(k))+yn(k) return end function a18lin C**************************************************************************** C* * C* SUBROUTINE A18INT * C* * C**************************************************************************** C C third order spline interpolation C input argument and function: X1(1:N1),Y1(1:N1) C output argument and function: X2(1:N2)X2(1:N2),Y2(1:N2) C the necessary conditionts are: X1(I) < X1(I+1), and the same for X2 array. C C called by cco2gr C calls nothing SUBROUTINE A18INT(X1,Y1,X2,Y2,N1,N2) ! ! Args: integer,intent(in) :: n1,n2 real,intent(in) :: X1(N1),Y1(N1) real,intent(out) :: X2(N2),Y2(N2) ! ! Local: real :: A(150),E(150),F(150),H(150),f1,f2,f3 integer :: k,kr,i,l,nvs real :: h1,h2,g ! H2=X1(1) NVS=N1-1 DO 1 K=1,NVS H1=H2 H2=X1(K+1) H(K)=H2-H1 1 CONTINUE A(1)=0. A(N1)=0. E(N1)=0. F(N1)=0. H1=H(N1-1) F1=Y1(N1-1) F2=Y1(N1) DO 2 KR=2,NVS K=NVS+2-KR H2=H1 H1=H(K-1) F3=F2 F2=F1 F1=Y1(K-1) G=1/(H2*E(K+1)+2.*(H1+H2)) E(K)=-H1*G F(K)=(3.*((F3-F2)/H2-(F2-F1)/H1)-H2*F(K+1))*G 2 CONTINUE G=0. DO 3 K=2,NVS G=E(K)*G+F(K) A(K)=G 3 CONTINUE L=1 DO 4 I=1,N2 G=X2(I) DO 6 K=L,NVS IF(G.GT.X1(K+1))GOTO6 L=K GOTO 5 6 CONTINUE L=NVS 5 G=G-X1(L) H2=H(L) F2=Y1(L) F1=H2**2 F3=G**2 Y2(I)=F2+G/H2*(Y1(L+1)-F2-(A(L+1)*(F1-F3)+ * A(L)*(2.*F1-3.*G*H2+F3))/3.) 4 CONTINUE RETURN END subroutine a18int !----------------------------------------------------------------------- real function quadrat(parm,hts,npts,spval) c c Integrate parm over hts (hts are input in km): c implicit none ! ! Args: integer,intent(in) :: npts real,intent(in) :: hts(npts),parm(npts) real,intent(in) :: spval ! ! Local: integer :: k real :: htcm(npts) ! write(6,"('enter quadrat: npts=',i3,' parm=',/,(6e12.4))") ! | npts,parm ! write(6,"('enter quadrat: hts=',/,(6e12.4))") hts ! htcm(:) = hts(:)*1.e5 quadrat = 0. do k=1,npts-1 if (parm(k).ne.spval.and.parm(k+1).ne.spval) + quadrat = quadrat+0.5*(parm(k)+parm(k+1))*(htcm(k+1)-htcm(k)) ! write(6,"('quadrat: k=',i3,' quadrat=',e12.4)") k,quadrat enddo return end !----------------------------------------------------------------------- logical function findf(varname,f) use fields use flds_airglow,only: nf_airglow,f_airglow use flds_atmos,only: nf_atmos,f_atmos use flds_col,only: nf_col,f_col use flds_dissoc,only: nf_dissoc,f_dissoc use flds_fields,only: nf_fields,f_fields,edy use flds_heat,only: nf_heat,f_heat, nf_totheat,f_totheat use flds_ionatm,only: nf_ionatm,f_ionatm use flds_ionzrt,only: nf_ionzrt,f_ionzrt use flds_prodloss,only: nf_prodloss,f_prodloss use flds_ratecoef,only: nf_ratecoef,f_ratecoef use flds_sodium,only: nf_sodium,f_sodium use flds_msisatm,only: nf_msisatm,f_msisatm use flds_modelz,only: nf_modelz,f_modelz use flds_hist,only: f_hist ! for debug implicit none ! ! Args: character(len=*),intent(in) :: varname type(field),intent(out) :: f ! ! Local: integer :: i ! findf = .false. do i=1,nf_airglow if (trim(f_airglow(i)%var_name)==trim(varname)) then f = f_airglow(i) findf = .true. endif enddo do i=1,nf_atmos if (trim(f_atmos(i)%var_name)==trim(varname)) then f = f_atmos(i) findf = .true. endif enddo do i=1,nf_col if (trim(f_col(i)%var_name)==trim(varname)) then f = f_col(i) findf = .true. endif enddo do i=1,nf_dissoc if (trim(f_dissoc(i)%var_name)==trim(varname)) then f = f_dissoc(i) findf = .true. endif enddo do i=1,nf_fields if (trim(f_fields(i)%var_name)==trim(varname)) then f = f_fields(i) findf = .true. endif enddo do i=1,nf_heat if (trim(f_heat(i)%var_name)==trim(varname)) then f = f_heat(i) findf = .true. endif enddo do i=1,nf_totheat if (trim(f_totheat(i)%var_name)==trim(varname)) then f = f_totheat(i) findf = .true. endif enddo do i=1,nf_ionatm if (trim(f_ionatm(i)%var_name)==trim(varname)) then f = f_ionatm(i) findf = .true. endif enddo do i=1,nf_ionzrt if (trim(f_ionzrt(i)%var_name)==trim(varname)) then f = f_ionzrt(i) findf = .true. endif enddo do i=1,nf_prodloss if (trim(f_prodloss(i)%var_name)==trim(varname)) then f = f_prodloss(i) findf = .true. endif enddo do i=1,nf_ratecoef if (trim(f_ratecoef(i)%var_name)==trim(varname)) then f = f_ratecoef(i) findf = .true. endif enddo do i=1,nf_sodium if (trim(f_sodium(i)%var_name)==trim(varname)) then f = f_sodium(i) findf = .true. endif enddo do i=1,nf_msisatm if (trim(f_msisatm(i)%var_name)==trim(varname)) then f = f_msisatm(i) findf = .true. endif enddo do i=1,nf_modelz if (trim(f_modelz(i)%var_name)==trim(varname)) then f = f_modelz(i) findf = .true. endif enddo ! if (findf) then ! write(6,"('findf: found field ',a,' class=',a,' min,max=', ! | 2e12.4)") varname,f%class(1:16), ! | minval(f%data),maxval(f%data) ! else ! write(6,"('>>> finf: could not find field ',a)") varname ! endif end function findf !------------------------------------------------------------------- recursive subroutine expand_path(path) ! ! Expand any environment variables imbedded in path, and return ! expanded path. ! Procedure: ! If '$' is found in input path, then an env var is defined as ! that part of path following the '$' up to (not including) the ! next delimiter. The value of the env var is substituted in place ! of the env var string. If no '$' is found, the routine returns ! without changing path. ! Environment vars can be set (using setenv) in the user's .cshrc file, ! in the job script (e.g., setenv from a shell var), or set manually ! in the shell before executing the model. ! ! The 7 recognized delimiters (meaning end of env var name) are: ! '/' (forward slash), ! '.' (dot), ! '_' (underscore), ! '-' (dash), ! ':' (colon), ! '#' (pound sign), and ! '%' (percent sign) ! ! This routine is recursive, so multiple env vars can be used in the ! same path, and in combination with different delimiters, see ! examples below. ! ! Examples: ! path = '$TGCMDATA/dir1/file.nc' (the env var is $TGCMDATA) ! path = '$MYDIR/$MYSUBDIR/file.nc' (env vars are $MYDIR, $MYSUBDIR) ! path = '$USER.$MODEL_$NUM.nc' (3 env vars and different delims) ! path = '$FILEPATH' (entire path in one env var) ! Last example: ! In the job script: ! set model = $tiegcm ! set a shell var ! setenv MODEL $model ! set env var from shell var ! In the namelist input: ! histfile = '$TGCMDATA/TGCM.$MODEL.p001-2002-080.nc' or ! histfile = '$TGCMDATA/TGCM.$MODEL.p001-$YEAR-$DAY.nc' ! implicit none ! ! Args: character(len=*),intent(inout) :: path ! ! Local: character(len=224) :: path_out,envvar_value character(len=80) :: envvar_name integer,parameter :: ndelim=7 character(len=1) :: delimiters(ndelim) = | (/ '/', '.', '-', '_', ':', '#', '%'/) integer :: i,idollar,idelim ! if (len_trim(path)==0) then write(6,"('>>> WARNING expand_path: path is empty.')") return endif ! ! write(6,"('Enter expand_path: path=',a)") trim(path) ! idollar = index(path,'$') if (idollar <= 0) return ! no env var in path ! ! Env var is between idollar and next slash ! (or end of path if there is no slash after idollar): ! idelim = 0 do i=idollar+1,len_trim(path) ! find next delimiter if (any(delimiters==path(i:i))) then idelim = i exit endif enddo if (idelim <= 0) idelim = len_trim(path)+1 envvar_name = path(idollar+1:idelim-1) ! write(6,"('expand_path: path=',a,' idollar=',i3, ! | ' idelim=',i3,' envvar_name=',a)") ! | trim(path),idollar,idelim,trim(envvar_name) ! ! Get value of env var (getenv is f90 intrinsic): call getenv(trim(envvar_name),envvar_value) if (len_trim(envvar_value) <= 0) then write(6,"('>>> WARNING expand_path: error retrieving ', | 'value for env var ''',a,'''')") trim(envvar_name) return else ! write(6,"('expand_path: envvar=',a,' value=',a)") ! | trim(envvar_name),trim(envvar_value) endif ! ! Put together the expanded output path: if (idollar > 1) then if (idelim < len_trim(path)) then path_out = path(1:idollar-1)//trim(envvar_value)// | path(idelim:len_trim(path)) else path_out = path(1:idollar-1)//trim(envvar_value) endif else ! idollar == 1 if (idelim < len_trim(path)) then path_out = trim(envvar_value)//path(idelim:len_trim(path)) else path_out = trim(envvar_value) endif endif ! ! Return new path, and make recursive call for more env vars: path = trim(path_out) write(6,"('expand_path returning path = ''',a,'''')") trim(path) ! ! Recursive call to expand any additional env vars: call expand_path(path) ! expand next env var ! end subroutine expand_path !------------------------------------------------------------------- real function expo(x,iprint) ! ! To avoid overflow/underflow on ieee system, argument range to ! exp() must be: -708.3964 < x < 709.7827 ! implicit none ! ! Args: real,intent(in) :: x integer,intent(in) :: iprint ! ! Local: real,parameter :: xmin=-708., xmax=+709., | big=.1e305, small=.1e-305 ! if (x >= xmin .and. x <= xmax) then expo = exp(x) elseif (x < xmin) then if (iprint > 0) write(6,"('expo iprint=',i2,' x=',e12.4, | ' setting expo = 0.')") iprint,x expo = 0. else if (iprint > 0) write(6,"('expo iprint=',i2,' x=',e12.4, | ' setting expo = big')") iprint,x expo = big endif end function expo