* This file contains the following subroutines, related to reading * simple input parameters from an input file, and interactive control. * rdinp * write1 * readin * chkval * newval * gethlp * select * atrim *=============================================================================* SUBROUTINE rdinp(intrct, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ims, slabel, imj, jlabel) *-----------------------------------------------------------------------------* *= This subroutine allows user input of some simple variables from a =* *= pre-exisiting file, or interactively. It also can be used to choose =* *= some simple outputs. =* *= Some help and checking of the user input values is performed, but is not =* *= comprehensive. =* *-----------------------------------------------------------------------------* IMPLICIT NONE INCLUDE 'params' * Input/output variables LOGICAL intrct CHARACTER*6 inpfil, outfil INTEGER nstr REAL lat, lon, tmzone INTEGER iyear, imonth, iday REAL zstart, zstop, wstart, wstop, tstart, tstop INTEGER nz, nwint, nt LOGICAL lzenit REAL alsurf, psurf, o3col, so2col, no2col REAL taucld, zbase, ztop, tauaer, ssaaer, alpha REAL dirsun, difdn, difup, zout, zaird, ztemp LOGICAL lirrad, laflux, lrates, ljvals, lmmech INTEGER isfix, ijfix, itfix, izfix, iwfix INTEGER nms, ims(ks), nmj, imj(kj) CHARACTER*50 slabel(ks), jlabel(kj) * Internal LOGICAL ls(ks), lj(kj) INTEGER ns, nj CHARACTER*7 avar, aerror INTEGER i LOGICAL okvalu, oktype, okfind, oknew LOGICAL lexist CHARACTER*6 savfil, tmpfil CHARACTER*20 finame INTEGER nlen * Headers and help lines INTEGER nhead, nhelp CHARACTER*70 ahline(400) *---------------------------------------------------------- ** initalize okvalu = .TRUE. oktype = .TRUE. okfind = .TRUE. oknew = .TRUE. IF(.NOT. intrct) GO TO 12 WRITE(*,100) 100 FORMAT(66('=')) * read headers and help file OPEN(UNIT=kin,FILE='helpin', STATUS='OLD') READ(kin,*) nhead, nhelp DO i = 1, nhelp-1 READ(kin,110) ahline(i) ENDDO 110 FORMAT(a70) CLOSE(kin) DO i = 1, nhead WRITE(*,*) ahline(i) ENDDO WRITE(*,100) WRITE(*,*) ' Type ?? for general information' WRITE(*,*) ' or to continue' READ(*,115) avar 115 FORMAT(A7) IF(avar(1:2) .EQ. '??' ) THEN CALL gethlp(avar, nhelp, ahline) read(*,*) CSM PAUSE ENDIF WRITE(*,100) * choose input file 10 CONTINUE WRITE(*,*) 'select input file' WRITE(*,*) ' : usrinp (if created before)' WRITE(*,*)' 1: defin1 (default No. 1, optimized for surface UV)' WRITE(*,*)' 2: defin2 (default No. 2, optimized for photochem )' WRITE(*,*)' 3: defin3 (default No. 3, optimized for master mech)' WRITE(*,*)' 4: defin4 (default No. 4, sample of all outputs)' WRITE(*,*)' 5: defin5 (default No. 5, spectra for WRF-chem)' WRITE(*,*) ' file-name for others ' READ(*,120) inpfil 120 FORMAT(a6) IF(inpfil .EQ. ' ') inpfil = 'usrinp' IF(inpfil(1:1) .EQ. '1') inpfil = 'defin1' IF(inpfil(1:1) .EQ. '2') inpfil = 'defin2' IF(inpfil(1:1) .EQ. '3') inpfil = 'defin3' IF(inpfil(1:1) .EQ. '4') inpfil = 'defin4' IF(inpfil(1:1) .EQ. '5') inpfil = 'defin5' 12 CONTINUE INQUIRE(file='INPUTS/'//inpfil,exist=lexist) IF(.NOT. lexist) THEN WRITE(*,*) '****** file does not exist: ', inpfil GO TO 10 ENDIF IF(inpfil .EQ. 'defin1' .OR. inpfil .EQ. 'defin2' .OR. $ inpfil .EQ. 'defin3') THEN OPEN(UNIT=kin,FILE='INPUTS/'//inpfil,STATUS='OLD') ELSE OPEN(UNIT=kin,FILE='INPUTS/'//inpfil,STATUS='UNKNOWN') ENDIF READ(kin,130) avar 130 FORMAT(A7) IF(avar .NE. 'TUV inp') THEN WRITE(*,*) 'This is not a legal TUV input file' GO TO 10 ENDIF WRITE(*,*) WRITE(*,*) * read input file: CALL readin( $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) CLOSE (kin) ************* check and report values: 20 CONTINUE CALL chkval(aerror, okvalu, oknew, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) IF (.NOT. intrct .AND. okvalu) GO TO 99 CALL write1(6, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) IF(.NOT. okvalu) THEN WRITE(*,*) $ '****** incorrect value for variable: ', aerror IF(.NOT. oknew) THEN WRITE(*,*) 'New value was put in table, re-type to confirm' ENDIF avar = aerror GO TO 40 ENDIF * confirm or change or get help 30 CONTINUE WRITE(*,*) 'Type ?variable for help on a variable, or' WRITE(*,*) ' = keep these settings, or' WRITE(*,*) 'Type variable name to change (lower case):' READ(*,300) avar 300 FORMAT(A7) * confirm IF(oktype .AND. okfind .AND. oktype .AND. avar .EQ. ' ') GO TO 50 * get help IF(avar(1:1) .EQ. '?') THEN CALL gethlp(avar, nhelp, ahline) read(*,*) CSM PAUSE GO TO 20 ENDIF * change values 40 CONTINUE CALL newval(avar,okfind,oktype, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) IF(.NOT. okfind) THEN WRITE(*,*) $ '****** no such variable - try again (r = refresh screen)' GO TO 30 ENDIF IF(.NOT. oktype) THEN WRITE(*,*) '****** improper type for variable ', avar GO TO 40 ENDIF IF(avar .EQ. 'inpfil') GO TO 12 GO TO 20 ** check output file name CALL atrim(outfil, tmpfil, nlen) c finame = tmpfil(1:nlen) finame = '../'//tmpfil(1:nlen)//'.txt' OPEN(UNIT=20,FILE=finame,STATUS='UNKNOWN',ERR=60) CLOSE(20) GO TO 65 60 CONTINUE CLOSE(20) WRITE(*,*) '****** improper file name', outfil avar = 'outfil' GO TO 40 65 CONTINUE **************** write inputs to new file: 50 CONTINUE WRITE(*,*) 'save inputs to file?' WRITE(*,*) ' = do not save' WRITE(*,*) ' 1 = save to file: usrinp ' WRITE(*,*) ' or write new file name' READ(*,500) savfil 500 FORMAT(A6) IF (savfil .EQ. ' ') GO TO 99 IF (savfil(1:1) .EQ. '1') savfil = 'usrinp' * check new file name: * (cannot overwrite default input files: defin1, defin2, defin3 ) CALL atrim(savfil, tmpfil, nlen) finame = tmpfil(1:nlen) IF(finame .EQ. 'defin1' .OR. finame .EQ. 'defin2' .OR. $ finame .EQ. 'defin3' .OR. finame .EQ. 'defin4') THEN WRITE(*,*) '****** Cannot overwrite default input files' GO TO 70 ENDIF OPEN(UNIT=20,FILE='INPUTS/'//finame,STATUS='UNKNOWN',ERR=70) GO TO 75 70 CONTINUE CLOSE(20) WRITE(*,*) '****** improper file name', savfil GO TO 50 75 CONTINUE CALL write1(20, $ savfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) CLOSE (20) ***** done 99 CONTINUE WRITE(*,*) 'done: loading inputs' CALL write1(kout, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) END *=============================================================================* SUBROUTINE write1(iout, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) IMPLICIT NONE INCLUDE 'params' * Input/output variables INTEGER iout CHARACTER*6 inpfil, outfil INTEGER nstr REAL lat, lon, tmzone INTEGER iyear, imonth, iday REAL zstart, zstop, wstart, wstop, tstart, tstop INTEGER nz, nwint, nt LOGICAL lzenit REAL alsurf, psurf, o3col, so2col, no2col REAL taucld, zbase, ztop, tauaer, ssaaer, alpha REAL dirsun, difdn, difup, zout, zaird, ztemp LOGICAL lirrad, laflux, lrates, ljvals, lmmech INTEGER isfix, ijfix, itfix, izfix, iwfix INTEGER nms, ims(ks), nmj, imj(kj) CHARACTER*50 slabel(ks), jlabel(kj) LOGICAL ls(ks), lj(kj) INTEGER ns, nj INTEGER i INTEGER ninp, nout CHARACTER*6 inpf, outf * right-justify 6-character file names CALL atrim(inpfil,inpf,ninp) CALL atrim(outfil,outf,nout) DO i = 1, 6 - ninp inpf = ' '//inpf ENDDO DO i = 1, 6 - nout outf = ' '//outf ENDDO IF(iout .EQ. 6) then WRITE(*,100) WRITE(*,1000) WRITE(*,105) inpf, outf, nstr WRITE(*,110) lat, lon, tmzone WRITE(*,115) iyear, imonth, iday WRITE(*,120) zstart, zstop, nz WRITE(*,125) wstart, wstop, nwint WRITE(*,130) tstart, tstop, nt WRITE(*,135) lzenit, alsurf, psurf WRITE(*,140) o3col, so2col, no2col WRITE(*,145) taucld, zbase, ztop WRITE(*,150) tauaer, ssaaer, alpha WRITE(*,155) dirsun, difdn, difup WRITE(*,160) zout, zaird, ztemp WRITE(*,165) lirrad, laflux, lmmech WRITE(*,170) lrates, isfix, nms WRITE(*,175) ljvals, ijfix, nmj WRITE(*,180) iwfix, itfix, izfix WRITE(*,1000) ELSE WRITE(iout,100) WRITE(iout,1000) WRITE(iout,105) inpf, outf, nstr WRITE(iout,110) lat, lon, tmzone WRITE(iout,115) iyear, imonth, iday WRITE(iout,120) zstart, zstop, nz WRITE(iout,125) wstart, wstop, nwint WRITE(iout,130) tstart, tstop, nt WRITE(iout,135) lzenit, alsurf, psurf WRITE(iout,140) o3col, so2col, no2col WRITE(iout,145) taucld, zbase, ztop WRITE(iout,150) tauaer, ssaaer, alpha WRITE(iout,155) dirsun, difdn, difup WRITE(iout,160) zout, zaird, ztemp WRITE(iout,165) lirrad, laflux, lmmech WRITE(iout,170) lrates, isfix, nms WRITE(iout,175) ljvals, ijfix, nmj WRITE(iout,180) iwfix, itfix, izfix WRITE(iout,1000) 1000 FORMAT(66('=')) IF(iout .EQ. kout ) then WRITE(iout,1012) 1012 FORMAT('==== Spectral weighting functions used:') DO i = 1, nms WRITE(iout,200) ls(ims(i)), i, slabel(ims(i)) ENDDO WRITE(iout,1022) 1022 FORMAT('==== Photolysis reactions used:') DO i = 1, nmj WRITE(iout,200) lj(imj(i)), i, jlabel(imj(i)) ENDDO WRITE(iout,1000) ELSE WRITE(iout,1010) 1010 FORMAT('===== Avaliable spectral weighting functions:') DO i = 1, ns WRITE(iout,200) ls(i), i, slabel(i) ENDDO WRITE(iout,1020) 1020 FORMAT('===== Available photolysis reactions:') DO i = 1, nj WRITE(iout,200) lj(i), i, jlabel(i) ENDDO 200 FORMAT(L1,I3,1X,A50) WRITE(iout,1000) ENDIF ENDIF 100 FORMAT('TUV inputs:') 105 FORMAT('inpfil = ',5x,A6, 3X,'outfil = ',5x,A6, $ 3X,'nstr = ',2X,I11) 110 FORMAT('lat = ',3X,F11.3,3X,'lon = ',3X,F11.3, $ 3X,'tmzone = ',F11.1) 115 FORMAT('iyear = ',1X,I11, 3X,'imonth = ',I11, $ 3X,'iday = ',2X,I11) 120 FORMAT('zstart = ',F11.3,3X,'zstop = ',1X,F11.3, $ 3X,'nz = ',4X,I11) 125 FORMAT('wstart = ',F11.3,3X,'wstop = ',1X,F11.3, $ 3X,'nwint = ',1X,I11) 130 FORMAT('tstart = ',F11.3,3X,'tstop = ',1X,F11.3, $ 3X,'nt = ',4X,I11) 135 FORMAT('lzenit = ',10X,L1,3X,'alsurf = ',F11.3, $ 3X,'psurf = ',1X,F11.1) 140 FORMAT('o3col = ',1X,F11.3,3X,'so2col = ',F11.3, $ 3X,'no2col = ',F11.3) 145 FORMAT('taucld = ',F11.3,3X,'zbase = ',1X,F11.3, $ 3X,'ztop = ',2X,F11.3) 150 FORMAT('tauaer = ',F11.3,3X,'ssaaer = ',F11.3, $ 3X,'alpha = ',1X,F11.3) 155 FORMAT('dirsun = ',F11.3,3X,'difdn = ',1X,F11.3, $ 3X,'difup = ',1X,F11.3) 160 FORMAT('zout = ',2X,0pF11.3,3X,'zaird = ',1X,1pE11.3, $ 3X,'ztemp = ',1X,0pF11.3) 165 FORMAT('lirrad = ',10X,L1, 3X,'laflux = ',10X,L1, $ 3X,'lmmech = ',10X,L1) 170 FORMAT('lrates = ',10X,L1, 3X,'isfix = ',1X,I11, $ 3X,'nms = ',3X,I11) 175 FORMAT('ljvals = ',10X,L1, 3X,'ijfix = ',1X,I11, $ 3X,'nmj = ',3X,I11) 180 FORMAT('iwfix = ',1X,I11, 3X,'itfix = ',1X,I11, $ 3X,'izfix = ',1X,I11) RETURN END *=============================================================================* SUBROUTINE readin( $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) IMPLICIT NONE INCLUDE 'params' * Input/output variables CHARACTER*6 inpfil, outfil INTEGER nstr REAL lat, lon, tmzone INTEGER iyear, imonth, iday REAL zstart, zstop, wstart, wstop, tstart, tstop INTEGER nz, nwint, nt LOGICAL lzenit REAL alsurf, psurf, o3col, so2col, no2col REAL taucld, zbase, ztop, tauaer, ssaaer, alpha REAL dirsun, difdn, difup, zout, zaird, ztemp LOGICAL lirrad, laflux, lrates, ljvals, lmmech INTEGER isfix, ijfix, itfix, izfix, iwfix INTEGER nms, ims(ks), nmj, imj(kj) CHARACTER*50 slabel(ks), jlabel(kj) LOGICAL ls(ks), lj(kj) INTEGER ns, nj * internal INTEGER i, idum READ(kin,*) READ(kin,105) inpfil, outfil, nstr READ(kin,110) lat, lon, tmzone READ(kin,115) iyear, imonth, iday READ(kin,120) zstart, zstop, nz READ(kin,125) wstart, wstop, nwint READ(kin,130) tstart, tstop, nt READ(kin,135) lzenit, alsurf, psurf READ(kin,140) o3col, so2col, no2col READ(kin,145) taucld, zbase, ztop READ(kin,150) tauaer, ssaaer, alpha READ(kin,155) dirsun, difdn, difup READ(kin,160) zout, zaird, ztemp READ(kin,165) lirrad, laflux, lmmech READ(kin,170) lrates, isfix, nms READ(kin,175) ljvals, ijfix, nmj READ(kin,180) iwfix, itfix, izfix READ(kin,*) 105 FORMAT(14X,A6, 3X,14X,A6, 3X,9X,I11) 110 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,F11.1) 115 FORMAT(9X,I11, 3X,9X,I11 ,3X,9X,I11) 120 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,I11) 125 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,I11) 130 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,I11) 135 FORMAT(19X,L1, 3X,9X,F11.3,3X,9X,F11.1) 140 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,F11.3) 145 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,F11.3) 150 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,F11.3) 155 FORMAT(9X,F11.3,3X,9X,F11.3,3X,9X,F11.3) 160 FORMAT(9X,F11.3,3X,9X,E11.3,3X,9X,F11.3) 165 FORMAT(19X,L1, 3X,19X,L1, 3X,19X,L1) 170 FORMAT(19X,L1, 3X,9X,I11, 3X,9X,I11) 175 FORMAT(19X,L1, 3X,9X,I11, 3X,9X,I11) 180 FORMAT(9X,I11, 3X,9X,I11 ,3X,9X,I11) * read spectral weighting function list, * and identify those to be used: READ(kin,*) ns = 0 nms = 0 DO i = 1, ks READ(kin,200,err=10) ls(i), idum, slabel(i) IF (idum .NE. i) STOP 'error in spectral function list' ns = ns + 1 IF(ls(i)) THEN nms = nms + 1 ims(nms) = idum ENDIF ENDDO * read photolysis reaction list, * and identify those to be used: 10 CONTINUE nj = 0 nmj = 0 DO i = 1, kj READ(kin,200,err=20) lj(i), idum, jlabel(i) IF (idum .NE. i) STOP 'error in photolysis reaction list' nj = nj + 1 IF(lj(i)) THEN nmj = nmj + 1 imj(nmj) = idum ENDIF ENDDO 200 FORMAT(L1,I3,1X,A50) 20 CONTINUE RETURN END *=============================================================================* SUBROUTINE chkval(aerror, okvalu, oknew, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) IMPLICIT NONE INCLUDE 'params' * Input/output variables LOGICAL okvalu, oknew CHARACTER*7 aerror CHARACTER*6 inpfil, outfil INTEGER nstr REAL lat, lon, tmzone INTEGER iyear, imonth, iday REAL zstart, zstop, wstart, wstop, tstart, tstop INTEGER nz, nwint, nt LOGICAL lzenit REAL alsurf, psurf, o3col, so2col, no2col REAL taucld, zbase, ztop, tauaer, ssaaer, alpha REAL dirsun, difdn, difup, zout, zaird, ztemp LOGICAL lirrad, laflux, lrates, ljvals, lmmech INTEGER isfix, ijfix, itfix, izfix, iwfix INTEGER nms, ims(ks), nmj, imj(kj) CHARACTER*50 slabel(ks), jlabel(kj) LOGICAL ls(ks), lj(kj) INTEGER ns, nj * Internal INTEGER jday, nday LOGICAL oky, okm, okd CHARACTER*6 finame INTEGER nlen * Initialize okvalu = .TRUE. oknew = .TRUE. **** Check All Values: * skip: * inpfil * outfil * number of streams must be even if larger than 2: * (if less than 2, uses 2-stream delta-Eddington) IF(nstr .GT. 2) THEN IF (2*(nstr/2) .NE. nstr .OR. nstr .GT. 32) THEN aerror = 'nstr' okvalu = .FALSE. RETURN ENDIF ENDIF * latitude must be between -90 and +90 degrees: IF(ABS(lat) .GT. 90.) THEN aerror = 'lat' okvalu = .FALSE. RETURN ENDIF * longitude must be between -180 and +180 degrees: IF(ABS(lon) .GT. 180.) THEN aerror = 'lon' okvalu = .FALSE. RETURN ENDIF * time zone must be between -12 and +12 hours: IF(ABS(tmzone) .GT. 12.) THEN aerror = 'tmzone' okvalu = .FALSE. RETURN ENDIF * check for legal dates: CALL calend(iyear, imonth, iday, $ jday, nday, oky, okm, okd) IF( .NOT. oky) THEN aerror = 'iyear' okvalu = .FALSE. RETURN ENDIF IF( .NOT. okm) THEN aerror = 'imonth' okvalu = .FALSE. RETURN ENDIF IF( .NOT. okd) THEN aerror = 'iday' okvalu = .FALSE. RETURN ENDIF * surface elevation must be equal to or larger than zero IF(zstart .LT. 0.) THEN aerror = 'zstart' okvalu = .FALSE. RETURN ENDIF * top of atmosphere should not exceed 120 km. IF(zstop .GT. 120.) THEN aerror = 'zstop' okvalu = .FALSE. RETURN ENDIF * number of altitude levels must not exceed kz-1 (set in include file) IF(nz .gt. kz - 1) THEN aerror = 'nz' okvalu = .FALSE. RETURN ENDIF * starting wavelength IF(wstart .lt. 100. .OR. wstart .GE. wstop) THEN aerror = 'wstart' okvalu = .FALSE. RETURN ENDIF * ending wavelength IF(wstop .gt. 1200.) THEN aerror = 'wstop' okvalu = .FALSE. RETURN ENDIF * number of wavelength intervals IF(nwint .EQ. 0 .OR. ABS(nwint) .GT. kw-1) THEN aerror = 'nwint' okvalu = .FALSE. RETURN ENDIF * starting and stop time (or solar zenith angle). * if zenith angle, must be between 0 and 180 deg. * if time, must be between -13 and +35 hrs. IF(lzenit) THEN IF(tstart .LT. 0. .OR. tstart .GT. 180.) THEN aerror = 'tstart' okvalu = .FALSE. RETURN ENDIF IF(tstop .LT. tstart .OR. tstop .GT. 180.) THEN aerror = 'tstop' okvalu = .FALSE. RETURN ENDIF ELSE IF(tstart .LT. -13. .OR. tstart .GT. 36.) THEN aerror = 'tstart' okvalu = .FALSE. RETURN ENDIF IF(tstop .LT. tstart .OR. tstop .GT. 36.) THEN aerror = 'tstop' okvalu = .FALSE. RETURN ENDIF ENDIF * number of time steps IF(nt .LT. 1 .OR. nt .GT. kt) THEN aerror = 'ntz' okvalu = .FALSE. RETURN ENDIF * skip: * lzenith * surface albedo IF(alsurf .LT. 0. .OR. alsurf .GT. 1.) THEN aerror = 'albnew' okvalu = .FALSE. RETURN ENDIF * skip: * surface pressure * SO2, and NO2 columns, cannot be negative * ok neg for O3, forces default colum c IF(o3col .LT. 0.) THEN c aerror = 'o3col' c okvalu = .FALSE. c RETURN c ENDIF IF(so2col .LT. 0.) THEN aerror = 'so2col' okvalu = .FALSE. RETURN ENDIF IF(no2col .LT. 0.) THEN aerror = 'no2col' okvalu = .FALSE. RETURN ENDIF * cloud optical depth, base, and top IF(taucld .LT. 0.) THEN aerror = 'taucld' okvalu = .FALSE. RETURN ENDIF IF(taucld .GT. 0.) THEN IF(zbase .LT. zstart) THEN aerror = 'zbase' okvalu = .FALSE. write(*,*) '****** zbase cannot be less than zstart' write(*,*) '****** changed to zbase = zstart' zbase = zstart oknew = .FALSE. RETURN ENDIF IF(ztop .LE. zbase) THEN aerror = 'ztop' okvalu = .FALSE. write(*,*) '****** ztop cannot be less than zbase' write(*,*) '****** changed to ztop = zbase + 0.01 km' ztop = zbase + 0.01 oknew = .FALSE. RETURN ENDIF ENDIF * aerosol optical depth, single scattering albedo, Angstrom coefficient IF(tauaer .LT. 0.) THEN aerror = 'tauaer' okvalu = .FALSE. RETURN ENDIF IF(ABS(ssaaer) .GT. 1.) THEN aerror = 'tssaaer' okvalu = .FALSE. RETURN ENDIF IF(alpha .LT. 0.) THEN aerror = 'alpha' okvalu = .FALSE. RETURN ENDIF * weighting factors for direct, diffuse radiation components IF(ABS(dirsun) .GT. 1.) THEN aerror = 'dirsun' okvalu = .FALSE. RETURN ENDIF IF(ABS(difdn) .GT. 1.) THEN aerror = 'difdn' okvalu = .FALSE. RETURN ENDIF IF(ABS(difup) .GT. 1.) THEN aerror = 'difup' okvalu = .FALSE. RETURN ENDIF * altitude for specific outputs. Cannot be less than zstart or more than * zstop IF(zout .LT. zstart) THEN aerror = 'zout' okvalu = .FALSE. write(*,*) '****** zout cannot be less than zstart' write(*,*) '****** changed to zout = zstart' oknew = .FALSE. zout = zstart RETURN ENDIF IF(zout .GT. zstop) THEN aerror = 'zout' okvalu = .FALSE. write(*,*) '****** zout cannot be more than zstop' write(*,*) '****** changed to zout = zstop' zout = zstop RETURN ENDIF * skip: * lirrad * laflux * lmmech * lrates * index of a spectral weighting function selected for detailed output IF(isfix .LT. 0 .OR. isfix .GT. nms) THEN aerror = 'isfix' okvalu = .FALSE. RETURN ENDIF * skip: * nms * ns * lrates * ls * slabel * Index of a spectral weighting function selected for detailed output IF(ijfix .LT. 0 .OR. ijfix .GT. nmj) THEN aerror = 'ijfix' okvalu = .FALSE. RETURN ENDIF * skip: * nmj * nj * ljvals * lj * jlabel * Index for output at fixed wavelength IF(iwfix .lt. 0 .OR. iwfix .GT. ABS(nwint)) THEN aerror = 'iwfix' okvalu = .FALSE. RETURN ENDIF * Index for output at fixed time IF(itfix .lt. 0 .OR. itfix .GT. nt) THEN aerror = 'itfix' okvalu = .FALSE. RETURN ENDIF * Index for output at fixed altitude IF(izfix .LT. 0 .OR. izfix .GT. nz) THEN aerror = 'izfix' okvalu = .FALSE. RETURN ENDIF IF(izfix .GT. 0) THEN zout = zstart + (zstop - zstart) * $ float(izfix-1)/float(nz-1) WRITE(*,*) '****** changed to zout = ', zout ENDIF RETURN END *=============================================================================* SUBROUTINE newval(avar,okfind,oktype, $ inpfil, outfil, nstr, lat, lon, tmzone, $ iyear, imonth, iday, zstart, zstop, nz, $ wstart, wstop, nwint, tstart, tstop, nt, $ lzenit, alsurf, psurf, o3col, so2col, no2col, $ taucld, zbase, ztop, tauaer, ssaaer, alpha, $ dirsun, difdn, difup, zout, zaird, ztemp, $ lirrad, laflux, lmmech, lrates, isfix, nms, $ ljvals, ijfix, nmj, iwfix, itfix, izfix, $ ns, ls, ims, slabel, nj, lj, imj, jlabel) IMPLICIT NONE INCLUDE 'params' * Input/output variables CHARACTER*7 avar LOGICAL oktype, okfind CHARACTER*6 inpfil, outfil INTEGER nstr REAL lat, lon, tmzone INTEGER iyear, imonth, iday REAL zstart, zstop, wstart, wstop, tstart, tstop INTEGER nz, nwint, nt LOGICAL lzenit REAL alsurf, psurf, o3col, so2col, no2col REAL taucld, zbase, ztop, tauaer, ssaaer, alpha REAL dirsun, difdn, difup, zout, zaird, ztemp LOGICAL lirrad, laflux, lrates, ljvals, lmmech INTEGER isfix, ijfix, itfix, izfix, iwfix INTEGER nms, ims(ks), nmj, imj(kj) CHARACTER*50 slabel(ks), jlabel(kj) LOGICAL ls(ks), lj(kj) INTEGER ns, nj * Internal INTEGER n oktype = .TRUE. okfind = .TRUE. n = INDEX(avar,' ') IF (avar(1:n-1) .EQ. 'r') RETURN IF (avar(1:n-1) .EQ. 'inpfil') THEN WRITE(*,*) 'write new value for ', avar READ(*,100,ERR=32)inpfil RETURN ENDIF 100 FORMAT(A6) IF (avar(1:n-1) .EQ. 'outfil') THEN WRITE(*,*) 'write new value for ', avar READ(*,100,ERR=32) outfil RETURN ENDIF IF (avar(1:n-1) .EQ. 'nstr') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) nstr RETURN ENDIF IF (avar(1:n-1) .EQ. 'lat') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) lat RETURN ENDIF IF (avar(1:n-1) .EQ. 'lon') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) lon RETURN ENDIF IF (avar(1:n-1) .EQ. 'tmzone') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) tmzone RETURN ENDIF IF (avar(1:n-1) .EQ. 'iyear') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) iyear RETURN ENDIF IF (avar(1:n-1) .EQ. 'imonth') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) imonth RETURN ENDIF IF (avar(1:n-1) .EQ. 'iday') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) iday RETURN ENDIF IF (avar(1:n-1) .EQ. 'zstart') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) zstart RETURN ENDIF IF (avar(1:n-1) .EQ. 'zstop') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) zstop RETURN ENDIF IF (avar(1:n-1) .EQ. 'nz') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) nz RETURN ENDIF IF (avar(1:n-1) .EQ. 'wstart') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) wstart RETURN ENDIF IF (avar(1:n-1) .EQ. 'wstop') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) wstop RETURN ENDIF IF (avar(1:n-1) .EQ. 'nwint') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) nwint RETURN ENDIF IF (avar(1:n-1) .EQ. 'tstart') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) tstart RETURN ENDIF IF (avar(1:n-1) .EQ. 'tstop') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) tstop RETURN ENDIF IF (avar(1:n-1) .EQ. 'nt') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) nt RETURN ENDIF IF (avar(1:n-1) .EQ. 'lzenit') THEN IF(lzenit) THEN lzenit = .FALSE. ELSE lzenit = .TRUE. ENDIF RETURN ENDIF IF (avar(1:n-1) .EQ. 'alsurf') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) alsurf RETURN ENDIF IF (avar(1:n-1) .EQ. 'psurf') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) psurf RETURN ENDIF IF (avar(1:n-1) .EQ. 'o3col') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) o3col RETURN ENDIF IF (avar(1:n-1) .EQ. 'so2col') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) so2col RETURN ENDIF IF (avar(1:n-1) .EQ. 'no2col') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) no2col RETURN ENDIF IF (avar(1:n-1) .EQ. 'taucld') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) taucld RETURN ENDIF IF (avar(1:n-1) .EQ. 'zbase') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) zbase RETURN ENDIF IF (avar(1:n-1) .EQ. 'ztop') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) ztop RETURN ENDIF IF (avar(1:n-1) .EQ. 'tauaer') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) tauaer RETURN ENDIF IF (avar(1:n-1) .EQ. 'ssaaer') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) ssaaer RETURN ENDIF IF (avar(1:n-1) .EQ. 'alpha') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) alpha RETURN ENDIF IF (avar(1:n-1) .EQ. 'dirsun') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) dirsun RETURN ENDIF IF (avar(1:n-1) .EQ. 'difdn') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) difdn RETURN ENDIF IF (avar(1:n-1) .EQ. 'difup') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) difup RETURN ENDIF IF (avar(1:n-1) .EQ. 'zout') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) zout RETURN ENDIF IF (avar(1:n-1) .EQ. 'zaird') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) zaird RETURN ENDIF IF (avar(1:n-1) .EQ. 'ztemp') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) ztemp RETURN ENDIF IF (avar(1:n-1) .EQ. 'lirrad') THEN IF(lirrad) THEN lirrad = .FALSE. ELSE lirrad = .TRUE. ENDIF RETURN ENDIF IF (avar(1:n-1) .EQ. 'laflux') THEN IF(laflux) THEN laflux = .FALSE. ELSE laflux = .TRUE. ENDIF RETURN ENDIF IF (avar(1:n-1) .EQ. 'lmmech') THEN IF(lmmech) THEN lmmech = .FALSE. ELSE lmmech = .TRUE. ENDIF RETURN ENDIF IF (avar(1:n-1) .EQ. 'lrates') THEN IF(lrates) THEN lrates = .FALSE. ELSE lrates = .TRUE. ENDIF RETURN ENDIF IF (avar(1:n-1) .EQ. 'isfix') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) isfix RETURN ENDIF IF (avar(1:n-1) .EQ. 'nms') THEN CALL select(ns,nms,ims,ls,slabel) RETURN ENDIF IF (avar(1:n-1) .EQ. 'ljvals') THEN IF(ljvals) THEN ljvals = .FALSE. ELSE ljvals = .TRUE. ENDIF RETURN ENDIF IF (avar(1:n-1) .EQ. 'ijfix') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) ijfix RETURN ENDIF IF (avar(1:n-1) .EQ. 'nmj') THEN CALL select(nj,nmj,imj,lj,jlabel) RETURN ENDIF IF (avar(1:n-1) .EQ. 'iwfix') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) iwfix RETURN ENDIF IF (avar(1:n-1) .EQ. 'itfix') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) itfix RETURN ENDIF IF (avar(1:n-1) .EQ. 'izfix') THEN WRITE(*,*) 'write new value for ', avar READ(*,*,ERR=32) izfix RETURN ENDIF okfind = .FALSE. RETURN 32 oktype = .FALSE. RETURN END *=============================================================================* SUBROUTINE gethlp(avar, nhelp, ahline) IMPLICIT NONE INTEGER nhelp CHARACTER*70 ahline(400) CHARACTER*7 avar INTEGER i, j, k IF(avar(1:2) .EQ. '??') THEN DO i = 1, nhelp IF(ahline(i)(1:2) .EQ. '??') THEN READ(ahline(i+1),*) j WRITE(*,2000) DO k = 1, j WRITE(*,*) ahline(i+1+k) ENDDO WRITE(*,2000) RETURN ENDIF ENDDO ELSEIF (avar(1:1) .EQ. '?') THEN DO i = 1, nhelp IF(ahline(i)(1:1) .EQ. '?') THEN IF(avar(2:7) .EQ. ahline(i)(2:7)) THEN READ(ahline(i+1),*) j WRITE(*,2000) DO k = 1, j WRITE(*,*) ahline(i+1+k) ENDDO WRITE(*,2000) RETURN ENDIF ENDIF ENDDO WRITE(*,2000) WRITE(*,*) '****** no help found for variable ', avar(2:7) ENDIF 2000 FORMAT(70('-')) RETURN END *=============================================================================* SUBROUTINE select(n,nm,im,l,label) IMPLICIT NONE * Input/output INTEGER n, nm, im(n) LOGICAL l(n) CHARACTER*50 label(n) * Internal INTEGER i, j, ii, jj, m CHARACTER*6 ainp m = 1 + n/10 10 CONTINUE DO 20 jj = 1, m 30 WRITE(*,2000) DO j = 1, 10 i = 10*(jj-1) + j IF (i .GT. n) GO TO 40 WRITE(*,200) l(i), i, label(i) ENDDO 40 CONTINUE WRITE(*,2000) WRITE(*,*) $ 'Number = toggle T/F' WRITE(*,*) $ 'n = next page' WRITE(*,*) $ 'r = return to first page' WRITE(*,*) $ ' = done' READ(*,100) ainp IF(ainp .EQ. ' ') GO TO 70 IF(INDEX(ainp,'n') .NE. 0) GO TO 20 IF(INDEX(ainp,'r') .NE. 0) GO TO 10 READ(ainp,110,ERR=50) ii IF(ii .LT. 1 .OR. ii .GT. n) GO TO 50 GO TO 60 50 CONTINUE WRITE(*,*) 'input error, try again' GO TO 30 60 CONTINUE IF(l(ii)) THEN l(ii) = .FALSE. ELSE l(ii) = .TRUE. ENDIF GO TO 30 20 CONTINUE 70 CONTINUE nm = 0 DO i = 1, n IF(l(i)) THEN nm = nm + 1 im(nm) = i ENDIF ENDDO 100 FORMAT(A6) 110 FORMAT(I6) 200 FORMAT(L1,I3,1X,A50) 2000 FORMAT(60('-')) RETURN END *=============================================================================* SUBROUTINE atrim(a,aa,n) * Trim blanks from character string * Input: a * Output: aa, n * Internal: i IMPLICIT NONE CHARACTER*6 a, aa INTEGER n, i aa = ' ' n = 0 DO i = 1, 6 IF(a(i:i) .NE. ' ') THEN n = n + 1 aa(n:n) = a(i:i) ENDIF ENDDO RETURN END