subroutine inpsub C ***************************************************************** wjr C reads management file into common blocks C C Edit History C 06-Feb-99 wjr created C include 'p1werm.inc' include 'wpath.inc' include 'm1subr.inc' include 'm1sim.inc' include 'm1geo.inc' include 'm1flag.inc' include 'm1dbug.inc' include 's1layr.inc' include 's1surf.inc' include 's1phys.inc' include 's1agg.inc' include 's1dbh.inc' include 's1dbc.inc' include 's1sgeo.inc' include 'h1hydro.inc' include 'h1scs.inc' include 'h1db1.inc' include 'file.fi' c + + + LOCAL COMMON BLOCKS + + + include 'main/main.inc' c + + + LOCAL VARIABLES + + + integer lay character line*256 integer isr c + + + FUNCTION DECLARATIONS + + + real setbds real plant_wat_g C integer linnum, typidx data linnum /0/, typidx /0/ C C open simulation run file call fopenk (lui1, sinfil, 'old') c read subregion information do 200 isr = 1,nsubr typidx = 0 100 if (typidx.eq.52) go to 200 linnum = linnum + 1 read (lui1,'(a)',err=81) line C C skip comment lines if (line(1:1) .eq. '#') go to 100 C C use case statement to appropriately assign values typidx = typidx + 1 select case (typidx) case (1) c read initial field conditions file am0sid(isr) = line case (2) read(line,*,err=81) am0tax(isr) case (3) read(line,*,err=81) nslay(isr) case (4) read(line,*,err=81) (aszlyt(lay,isr), lay=1,nslay(isr)) c read soil physical properties case (5) read(line,*,err=81) (asfsan(lay,isr), lay=1,nslay(isr)) case (6) read(line,*,err=81) (asfsil(lay,isr), lay=1,nslay(isr)) case (7) read(line,*,err=81) (asfcla(lay,isr), lay=1,nslay(isr)) case (8) read(line,*,err=81) (asvroc(lay,isr), lay=1,nslay(isr)) case (9) read(line,*,err=81) (asfcs(lay,isr), lay=1,nslay(isr)) case (10) read(line,*,err=81) (asfms(lay,isr), lay=1,nslay(isr)) case (11) read(line,*,err=81) (asffs(lay,isr), lay=1,nslay(isr)) case (12) read(line,*,err=81) (asfvfs(lay,isr), lay=1,nslay(isr)) case (13) read(line,*,err=81) (asfwdc(lay,isr), lay=1,nslay(isr)) case (14) read(line,*,err=81) (asdblk(lay,isr), lay=1,nslay(isr)) C *** debugging write c write(*,*) ' inpsub: ', asdblk(1:7,isr) C *** eodw case (15) read(line,*,err=81) (asdwblk(lay,isr), lay=1,nslay(isr)) case (16) c aggregate properties read(line,*,err=81) (aslagm(lay,isr), lay=1,nslay(isr)) case (17) read(line,*,err=81) (as0ags(lay,isr), lay=1,nslay(isr)) case (18) read(line,*,err=81) (aslagx(lay,isr), lay=1,nslay(isr)) case (19) read(line,*,err=81) (aslagn(lay,isr), lay=1,nslay(isr)) case (20) read(line,*,err=81) (asdagd(lay,isr), lay=1,nslay(isr)) case (21) read(line,*,err=81) (aseags(lay,isr), lay=1,nslay(isr)) case (22) c read crust properties read(line,*,err=81) aszcr(isr) case (23) read(line,*,err=81) asdcr(isr) case (24) read(line,*,err=81) asecr(isr) case (25) read(line,*,err=81) asfcr(isr) case (26) c read surface properties read(line,*,err=81) asmlos(isr) c write(*,*) ' inpsub: asmlos(isr) ', asmlos(isr) case (27) read(line,*,err=81) asflos(isr) case (28) read(line,*,err=81) aslrr(isr) aslrro(isr) = aslrr(isr) case (29) read(line,*,err=81) asargo(isr) case (30) read(line,*,err=81) aszrgh(isr) case (31) read(line,*,err=81) asxrgs(isr) case (32) read(line,*,err=81) asxrgw(isr) case (33) c read soil hydrologic properties read(line,*,err=81) (ahrwc(lay,isr), lay=1,nslay(isr)) case (34) read(line,*,err=81) (ahrwcs(lay,isr), lay=1,nslay(isr)) case (35) read(line,*,err=81) (ahrwcf(lay,isr), lay=1,nslay(isr)) c convert this value, since it is volumetric and should be gravimetric c do lay=1,nslay(isr) c ahrwcf(lay,isr) = ahrwcf(lay,isr) / asdwblk(lay,isr) c end do case (36) read(line,*,err=81) (ahrwcw(lay,isr), lay=1,nslay(isr)) c convert this value also for testing purposes c do lay=1,nslay(isr) c ahrwcw(lay,isr) = ahrwcw(lay,isr) / asdwblk(lay,isr) c end do case (37) read(line,*,err=81) (ahrwc1(lay,isr), lay=1,nslay(isr)) case (38) read(line,*,err=81) (ah0cb(lay,isr), lay=1,nslay(isr)) case (39) read(line,*,err=81) (aheaep(lay,isr), lay=1,nslay(isr)) case (40) read(line,*,err=81) (ahrsk(lay,isr), lay=1,nslay(isr)) case (41) read(line,*,err=81) ah0cnp(isr) case (42) read(line,*,err=81) ah0cng(isr) case (43) read(line,*,err=81) asfald(isr) c calculate wet albedo from dry asfalw(isr)=asfald(isr)/((1.33**2.)*(1-asfald(isr)) * +asfald(isr)) case (44) c read soil chemical properties read(line,*,err=81) (asfom(lay,isr), lay=1,nslay(isr)) c the three vars are set so set auxillary density and water content values do 210 lay=1,nslay(isr) c set soil to field capacity not wilting point ahrwc(lay,isr) = ahrwcf(lay,isr) c find calculated value for settled bulk density asdsblk(lay,isr)=setbds(asfcla(lay,isr), asfsan(lay,isr), * asfom(lay,isr)) c make sure settled bd is greater than or equal to wet bulk density if( asdsblk(lay,isr).lt.asdwblk(lay,isr) ) then asdsblk(lay,isr) = asdwblk(lay,isr) endif c set initial condition to wet bulk density, not dry asdblk(lay,isr) = asdwblk(lay,isr) c calculate an average soil particle density c Particle density of organic matter c 1.37 in Baver, Soil Physics, 1972 p.44 (humus) c 1.1 in Marshall and Holmes, Soil Physics, 1979, p.277 (soil organic matter) asdpart(lay,isr) = asfom(lay,isr)*1.23 & + (1.0-asfom(lay,isr))*2.65 c make sure particle density is significantly greater than settled bulk density if( asdpart(lay,isr).lt.(1.2*asdsblk(lay,isr)) ) then asdpart(lay,isr) = 1.2*asdsblk(lay,isr) endif c set saturation based on definition c ahrwcs(lay,isr) = 1.0/asdblk(lay,isr)-1.0/asdpart(lay,isr) if(ahrwcs(lay,isr).lt.ahrwcf(lay,isr)) then c ahrwcf(lay,isr) = ahrwcs(lay,isr) write(*,*) 'Layer, Field Capacity > Saturation', & lay, ahrwcf(lay,isr), ahrwcs(lay,isr) endif c output for soil file screening c write(*,1000) sinfil,lay,aszlyt(lay,isr), c & asfsan(lay,isr),asfcla(lay,isr),asfom(lay,isr), c & asdwblk(lay,isr),asdblk(lay,isr),ahrwcs(lay,isr), c & ahrwcf(lay,isr),ahrwcw(lay,isr), c & ahrwcf(lay,isr)-ahrwcw(lay,isr), c & 1.0 - asdwblk(lay,isr)/asdpart(lay,isr), c & ahrwcf(lay,isr)*asdwblk(lay,isr), c & ahrwcw(lay,isr)*asdwblk(lay,isr), c & ahrwcf(lay,isr)*asdwblk(lay,isr)- c & ahrwcw(lay,isr)*asdwblk(lay,isr) 210 continue c used with output for soil file screening c 1000 format(a50,i2,f7.0,20f7.4) c stop c write out the soil water capacity plant available by depth write(*,*) 'inpsub:total 500mm', & plant_wat_g( 0.0, 500.0, ahrwcf(1,isr), ahrwcw(1,isr), & asdblk(1,isr), aszlyt(1,isr), nslay(isr) ), & plant_wat_g( 500.0, 1000.0, ahrwcf(1,isr), ahrwcw(1,isr), & asdblk(1,isr), aszlyt(1,isr), nslay(isr) ), & plant_wat_g( 1000.0, 1500.0, ahrwcf(1,isr), ahrwcw(1,isr), & asdblk(1,isr), aszlyt(1,isr), nslay(isr) ) case (45) read(line,*,err=81) (as0ph(lay,isr), lay=1,nslay(isr)) case (46) read(line,*,err=81) (asfcce(lay,isr), lay=1,nslay(isr)) c read other soil chemical properties needed by the CROP case (47) read(line,*,err=81) (asfcec(lay,isr), lay=1,nslay(isr)) case (48) read(line,*,err=81) (asfsmb(lay,isr), lay=1,nslay(isr)) case (49) read(line,*,err=81) (as0ec(lay,isr), lay=1,nslay(isr)) case (50) read(line,*,err=81) (asrsar(lay,isr), lay=1,nslay(isr)) case (51) read(line,*,err=81) (asftan(lay,isr), lay=1,nslay(isr)) case (52) read(line,*,err=81) (asftap(lay,isr), lay=1,nslay(isr)) end select goto 100 200 continue do isr = 1, nsubr write(*,*) 'checking spllay:',aszlyt(1,isr) if (aszlyt(1,isr) .ne. 10.0) call spllay enddo close (lui1) c some soil characteristic values for crop nutirent effects c were originally planned and then dropped. Debugging complains c that these values are not initialized when they are mixed as c part of management process. they are initialized here to avoid c removing them from mix and invert do isr = 1, nsubr do lay = 1, nslay(isr) ascmg(lay,isr) = 0.0 ascna(lay,isr) = 0.0 asfesp(lay,isr) = 0.0 asfnoh(lay,isr) = 0.0 asfpoh(lay,isr) = 0.0 asfpsp(lay,isr) = 0.0 end do end do C c call dmpall('wrk.dmp') return 81 write(*,9001) sinfil, linnum, line 9001 format('Error in file ',a,' on line #',i4,' ',a) stop 2220 format (/,' error, latitude is not between 0. and 90. degrees',/,' & - please check run file') 2230 format (/,' error, longitude is not between 0. and 360. degrees',/ &,' - please check run file') 2240 format (/,' error, initial or last day of simulation is out of bou &nds',/,' - please check run file') 2250 format (/,' error, initial or last day or month of simulation is o &ut of bounds',/,' - please check run file') 2260 format (/,' error, initial or last year of simulation is not betwe &en 0 and 99',/,' - please check run file') 2265 format (/,' error, initial year of simulation is greater than the &last year of simulation',/,' - please check run file') end