readmgt.f

水文模型的原始代码

            else
              nhv = 1
            end if 
            nkill = 1
            nhvo = 0
            npst = 0
            nir = 0
            ifn = 0
            inop = 0
            igr = 0
            nairr = 1
            nafer = 0
            nsw = 0
            icf = 0
            icp = 0
            exit

          case (1)  !! plant operation
            igrow = 1
            if (igro(ihru) == 1) idplt(1,1,ihru) = mgt1i
            npl = npl + 1
            idplt(iro,npl,ihru) = mgt1i
            idplt(iro,npl+1,ihru) = mgt1i
            lcr = mgt1i
            iplant(iro,npl,ihru) = Jdt(ndays,day,mon)
            if (mgt4 < 700.) mgt4 = 1700.
            if (mgt4 > 3500.) mgt4 = 3500.
            phu_plt(iro,npl,ihru) = mgt4
            phu_plt(iro,npl+1,ihru) = mgt4
            if (husc > .5) husc = .15      !!CEAP fix for winter crops
            if (husc > 0.) then
              phup(iro,npl,ihru) = husc
              if (husc > .5) phup(iro,npl+1,ihru) = husc
            endif
            cnop(iro,npl,ihru) = mgt9
            curyr_mat(ihru) = mgt3i
            hi_targ(iro,npl,ihru) = mgt7
            bio_targ(iro,npl,ihru) = mgt8 * 1000.
            lai_init(iro,npl,ihru) = mgt5
            bio_init(iro,npl,ihru) = mgt6
          
            !! calculate tnylda for autofertilization 
            if (hvsti(mgt1i) < 1.) then
              tnylda(iro,npl,ihru) = 350. * cnyld(mgt1i) * bio_e(mgt1i)
            else
              tnylda(iro,npl,ihru) = 1000. * cnyld(mgt1i) * bio_e(mgt1i)
            endif

          case (2)  !! irrigation operation
            kirr(ihru) = "x"
            nir = nir + 1
            irr_amt(iro,nir,ihru) = mgt4
            iir(iro,nir,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phuirr(iro,nir,ihru) = husc
            irr_salt(iro,nir,ihru) = mgt5
        
          case (3)  !! fertilizer operation
            if (mgt1i > 0) then           !! no fertilizer id #, ignore operation
              ifn = ifn + 1
              ifert(iro,ifn,ihru) = Jdt(ndays,day,mon)
              if (husc > 0.) phun(iro,ifn,ihru) = husc
              frt_surface(iro,ifn,ihru) = mgt5
              if (frt_surface(iro,ifn,ihru) <= 1.e-6)                   &
     &                                    frt_surface(iro,ifn,ihru) = .2
              ifrttyp(iro,ifn,ihru) = mgt1i
              frt_kg(iro,ifn,ihru) = mgt4
            end if
!! Pinue adjustments!!
c	written by Ann van Griensven	
	if (iclb.eq.9) then
	call pinuesamp(psamp,isamp(6))
	frt_kg(iro,ifn,ihru)=frt_kg(iro,ifn,ihru) *
     *	(1.+ (stpfrt(ihru,1)+stpfrt(ihru,2))/100.)
	end if
          case (4)  !! pesticide application
            hrupest(ihru) = 1
            npst = npst + 1
            ipst(iro,npst,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phupst(iro,npst,ihru) = husc
            pst_kg(iro,npst,ihru) = mgt4
            ipest(iro,npst,ihru) = mgt1i

            newpest = 0
            do j = 1, npmx
              if (mgt1i == npno(j)) then
                newpest = 1
                exit
              endif
            end do
            if (newpest == 0) then
              npno(npmx) = mgt1i
              nope(mgt1i) = npmx
              npmx = npmx + 1
            end if
!! Pinue adjustments!!
c	written by Ann van Griensven	
	if (iclb.eq.9) then
	call pinuesamp(psamp, isamp(6))
	pst_kg(iro,ifn,ihru)=pst_kg(iro,ifn,ihru)                         
     *		* (1.+ (stppst(ihru,1)+stppst(ihru,2))/100.)
	end if	
          case (5)  !! harvest and kill operation
            nhv = nhv + 1
            igrow = 0
            ihv(iro,npl,ihru) = Jdt(ndays,day,mon)
            if (nhv > 1) then
              if (ihv(iro,nhv-1,ihru) <= 0) then
                ihv(iro,nhv-1,ihru) = ihv(iro,nhv,ihru)
              end if
            end if 
            if (husc > 0.) then
              phuh(iro,npl,ihru) = husc
              phuh(iro,npl+1,ihru) = husc
            endif
            cnop(iro,npl,ihru) = mgt4

          case (6)  !! tillage operation
            inop = inop + 1
            iop(iro,inop,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phut(iro,inop,ihru) = husc
            idtill(iro,inop,ihru) = mgt1i
            cnop(iro,inop,ihru) = mgt4

          case (7)  !! harvest only operation
            nhvo = nhvo + 1
            ihvo(iro,nhvo,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phuho(iro,nhvo,ihru) = husc
            hi_ovr(iro,nhvo,ihru) = mgt5
            harveff(iro,nhvo,ihru) = mgt4
            if (harveff(iro,nhvo,ihru) <= 0.) then
              harveff(iro,nhvo,ihru) = 1.
            endif

          case (8)  !! kill operation
            nkill = nkill + 1
            igrow = 0
            ikill(iro,npl,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phuk(iro,npl,ihru) = husc
!           idplt(iro,npl+1,ihru) = lcr

          case (9)  !! grazing operation
            igr = igr + 1
            igraz(iro,igr,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phug(iro,igr,ihru) = husc
            if (bio_min(ihru) <= 1.e-4) bio_min(ihru) = 3000.
            bio_eat(iro,igr,ihru) = mgt4
            grz_days(iro,igr,ihru) = mgt1i
            bio_trmp(iro,igr,ihru) = mgt5
            manure_kg(iro,igr,ihru) = mgt6
            if (manure_kg(iro,igr,ihru) <= 0.) then
              manure_kg(iro,igr,ihru) = .95 * mgt4
            endif
            manure_id(iro,igr,ihru) = mgt2i

          case (10)  !! auto irrigation operation
            nairr = nairr + 1
            iairr(iro,nairr-1,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phuai(iro,nairr-1,ihru) = husc
            if (mgt1i <= 0) mgt1i = 1
            wstrs_id(iro,nairr,ihru) = mgt1i
            auto_wstr(iro,nairr,ihru) = mgt4
            kirr(ihru) = "x"

          case (11)  !! auto fertilizer operation
            if (mgt1i > 0) then  
              nafer = nafer + 1
              iafer(iro,nafer,ihru) = Jdt(ndays,day,mon)
              if (husc > 0.) phuaf(iro,nafer,ihru) = husc
              afrt_surface(ihru) = mgt8
              if (afrt_surface(ihru) <= 1.e-6) afrt_surface(ihru) = .2
              auto_nstrs(ihru) = mgt4
              iafrttyp(ihru) = mgt1i
              auto_napp(ihru) = mgt5
              if (auto_napp(ihru) <= 0.) auto_napp(ihru) = 200.
              auto_nyr(ihru) = mgt6
              if (auto_nyr(ihru) <= 0.) auto_nyr(ihru) = 300.
              auto_eff(ihru) = mgt7
              if (auto_eff(ihru) <= 0.) auto_eff(ihru) = 1.3
            end if
          
          case (12)  !! street sweeping  (only if IURBAN=2)
            nsw = nsw + 1
            isweep(iro,nsw,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phusw(iro,nsw,ihru) = husc
            sweepeff(iro,nsw,ihru) = mgt4
            fr_curb(iro,nsw,ihru) = mgt5
            if (fr_curb(iro,nsw,ihru) <= 0.) fr_curb(iro,nsw,ihru) = 1.0
        
          case (13)  !! release/impound water in rice fields
            nrel = nrel + 1
            imp_trig(iro,nrel+1,ihru) = mgt1i
            irelease(iro,nrel,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phuimp(iro,nrel,ihru) = husc

          case (14)  !! continuous fertilization operation
            icf = icf + 1
            icfert(iro,icf,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phucf(iro,icf,ihru) = husc
            fert_days(iro,icf,ihru) = mgt1i
            cfrt_kg(iro,icf,ihru) = mgt4
            cfrt_id(iro,icf,ihru) = mgt2i
            ifrt_freq(iro,icf,ihru) = mgt3i
            if (ifrt_freq(iro,icf,ihru) <= 0) then
              ifrt_freq(iro,icf,ihru) = 1
            end if
 
          case (15)  !! continuous pesticide operation
            icp = icp + 1
            icpest(iro,icp,ihru) = Jdt(ndays,day,mon)
            if (husc > 0.) phucp(iro,icp,ihru) = husc
            pest_days(iro,icp,ihru) = mgt2i
            cpst_kg(iro,icp,ihru) = mgt4
            cpst_id(iro,icp,ihru) = mgt1i
            ipst_freq(iro,icp,ihru) = mgt3i
            if (ipst_freq(iro,icp,ihru) <= 0) then
              ipst_freq(iro,icp,ihru) = 1
            end if
 
            newpest = 0
            do j = 1, npmx
              if (mgt1i == npno(j)) then
                newpest = 1
                exit
              endif
            end do
            if (newpest == 0) then
              npno(npmx) = mgt1i
              nope(mgt1i) = npmx
              npmx = npmx + 1
            end if

          end select
          end do

        if (iro == nrot(ihru)) exit
        end do
        idplt(1,1,ihru) = lcr
        do irotate = 2, nrot(ihru)
         if (idplt(irotate,1,ihru) == 0) idplt(irotate,1,ihru) =        &
     &     idplt(irotate-1,1,ihru)
         if (tnylda(irotate,2,ihru) == 0) tnylda(irotate,2,ihru) =      &
     &     tnylda(irotate-1,2,ihru)
         if (tnylda(irotate,1,ihru) == 0) tnylda(irotate,1,ihru) =      &
     &     tnylda(irotate,2,ihru)
        enddo
      end if

      close (109)
     
      return
 5000 format (a)
 5200 format (1x,i2,1x,i2,1x,f8.3,1x,i2,1x,i4,1x,i3,1x,i2,1x,f12.5,1x,  &
     &        f6.2,1x,f11.5,1x,f4.2,1x,f6.2,1x,f5.2)
      end