c $Header: /usr/people/flittner/radtran/tomrad/pv2.2/src/RCS/rdenv.f,v 2.22 2000/08/30 16:38:09 flittner Exp $ subroutine rdenv c c read the environment varibles to set the switchs for operation and pass c the results back in common blocks. c c***************************************************************************** c lsphout = True, then perform the out going beam using c spherical geometry. If False, then use flat atmosphere. c c ngas=1, then only allow 1 absorbing gas c c ipsudo=1, then do spherical correction of solar beam c c lprtflx=.TRUE., then print the flux table c c ldown=.FALSE., then calculate the reflected radiance at the top of the atmo c c lphiindep=.TRUE., then the table is az independent c (can be T or F for ipsudo=0,1, but only T for ipsudo=2) c c last mod. Sep. 2, 1998...def c purpose: use includes for the common blocks. Also, pass ipsudo through c the in common block (in.cmn). c c last mod. Sep. 2, 1998...def c purpose: read the file ENV instead of the unix environment variables. c Also input file names if there are any. c c last mod. Sep. 6, 1998...def c purpose: combine several commons into switches.cmn. Take-out c lreadmu input. Now is controled by the contents of the PROF file. c Also can input fluxout file name for both ascii and binary files. c c last mod. Oct. 14, 1998...def c purpose: add userfn (user input profile file name). c c last mod. May 3, 1999...def c purpose: add option to compute addition absorbing gas profile using the c internal, implicit neutral density profile and a constant mixing ratio. c Currently it is set to do only o2 or o4 absorption and is controled by c the lo2abs and lo4abs logicals read in the ENV file. c c last mod. Nov 2, 1999...def c purpose: use .not. instead of .eqv. in logical testing. c c last mod. Feb. 10, 2000...def c purpose: add switch to turn-off call to geopro c c last mod. Apr. 14, 2000...def c purpose: add switch to turn-on o3 weighting of temperatures. c c***************************************************************************** implicit none c include 'switches.cmn' include 'cgas2.cmn' include 'in.cmn' include 'cfilenames.cmn' c local character buf*200 logical ex,user_file integer i3,i4,l,j c functions integer char2int logical torf external torf,char2int c user_file=.FALSE. c inquire(file='ENV',exist=ex) if(ex)then c read the ENV file open(12,file='ENV',status='old') 10 read(12,'(a)',end=20)buf j=index(buf,'=') if(j.gt.0)then c get the before and after the = sign and trim all the white space call trimwhite(buf(j+1:),i3,i4) c logical switchs if(index(buf(1:j-1),'lsphout').gt.0) then lsphout=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lprtflx').gt.0) then lprtflx=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'ldown').gt.0) then ldown=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lphiindep').gt.0) then lphiindep=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'write_iter_file').gt.0) then write_iter_file=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lo2abs').gt.0) then lo2abs=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lo4abs').gt.0) then lo4abs=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lcontrb').gt.0) then lcontrb=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lnoextrap').gt.0) then lnoextrap=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lwgttmp').gt.0) then lwgttmp=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lwgt11').gt.0) then lwgt11=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lv7tab').gt.0) then lv7tab=torf(buf(j+i3:j+i4)) else if(index(buf(1:j-1),'lv7tabout').gt.0) then lv7tabout=torf(buf(j+i3:j+i4)) c integers else if(index(buf(1:j-1),'ngas').gt.0)then l=i4-i3+1 ngas=char2int(buf(j+i3:j+i4),l) if(ngas.le.0)ngas=1 if(ngas.gt.mgas+1)then write(6,*)'Can only do ',mgas+1,' absorbing gases.' ngas=mgas+1 endif else if(index(buf(1:j-1),'ipsudo').gt.0)then l=i4-i3+1 ipsudo=char2int(buf(j+i3:j+i4),l) ipsudo=max(ipsudo,0) ipsudo=min(ipsudo,2) else if(index(buf(1:j-1),'gc_type').gt.0)then l=i4-i3+1 gc_type=char2int(buf(j+i3:j+i4),l) gc_type=max(gc_type,0) gc_type=min(gc_type,4) else if(index(buf(1:j-1),'prf_type').gt.0)then l=i4-i3+1 prf_type=char2int(buf(j+i3:j+i4),l) prf_type=max(prf_type,0) prf_type=min(prf_type,2) else if(index(buf(1:j-1),'irefrac').gt.0)then l=i4-i3+1 irefrac=char2int(buf(j+i3:j+i4),l) irefrac=max(irefrac,0) irefrac=min(irefrac,1) c file names else if(index(buf(1:j-1),'inprffn').gt.0)then inprffn=buf(j+i3:j+i4) else if(index(buf(1:j-1),'nvalfn').gt.0)then nvalfn=buf(j+i3:j+i4) else if(index(buf(1:j-1),'outerrfn').gt.0)then outerrfn=buf(j+i3:j+i4) else if(index(buf(1:j-1),'outprffn').gt.0)then outprffn=buf(j+i3:j+i4) else if(index(buf(1:j-1),'sumryfn').gt.0)then sumryfn=buf(j+i3:j+i4) else if(index(buf(1:j-1),'iterfn').gt.0)then iterfn=buf(j+i3:j+i4) else if(index(buf(1:j-1),'coeffn').gt.0)then coeffn=buf(j+i3:j+i4) else if(index(buf(1:j-1),'outflxfnasc').gt.0)then outflxfnasc=buf(j+i3:j+i4) else if(index(buf(1:j-1),'outflxfnbin').gt.0)then outflxfnbin=buf(j+i3:j+i4) else if(index(buf(1:j-1),'userfn').gt.0)then user_file=.TRUE. userfn=buf(j+i3:j+i4) prf_type=2 endif endif goto 10 20 close(12) c c make consitent c if(user_file)prf_type=2 if(ipsudo.eq.2)lphiindep=.FALSE. if((lo2abs).or.(lo4abs))then c check to see if ngas is set greater than 1 if(ngas.le.1)then write(6,1000)ngas 1000 format('The logical switches lo2abs and/or lo4abs have been ', &'set TRUE, but the #',/,'of absorbing gases (ngas) =',i3, &'. So will set lo2abs and lo4abs to FALSE.') lo2abs=.FALSE. lo4abs=.FALSE. else if((lo2abs).and.(lo4abs).and.(ngas.lt.3))then write(6,1000)ngas lo2abs=.FALSE. lo4abs=.FALSE. else if((lo2abs).and.(.not.lo4abs).and.(ngas.lt.2))then write(6,1000)ngas lo2abs=.FALSE. lo4abs=.FALSE. else if((lo4abs).and.(.not.lo2abs).and.(ngas.lt.2))then write(6,1000)ngas lo2abs=.FALSE. lo4abs=.FALSE. endif if(ngas.gt.mgas+1)then write(6,*)'Can only do ',mgas+1,' absorbing gases.' ngas=mgas+1 endif endif endif c return end c subroutine trimwhite(word,i1,i2) implicit none character word*(*) c integer l,i2,i1 c l=len(word) i1=1 do while(word(i1:i1).eq.' ') i1=i1+1 enddo i2=index(word(i1+1:),' ') if(i2.lt.1)then i2=l else i2=i1+i2-1 endif c write(6,*)'^^^',word(i1:i2),'^^^' return end logical function torf(word) implicit none character word*(*) c if((word.eq.'.TRUE.').or.(word.eq.'.true.') &.or.(word.eq.'.T.').or.(word.eq.'.t.') &.or.(word.eq.'T').or.(word.eq.'t'))then torf=.TRUE. else if((word.eq.'.FALSE.').or.(word.eq.'.false.') &.or.(word.eq.'.F.').or.(word.eq.'.f.') &.or.(word.eq.'F').or.(word.eq.'f'))then torf=.FALSE. endif return end