c file: cinput.for subroutine cinput c Author : Amare Retta c + + + PURPOSE + + + c This subroutine reads crop growth parameter data c + + + KEYWORDS + + + c input, crop character cropnm*60 c + + + GLOBAL COMMON BLOCKS + + + *$noreference include 'p1werm.inc' c include 'm1sim.inc' include 'wpath.inc' include 'm1subr.inc' include 'm1flag.inc' include 'm1dbug.inc' include 'c1info.inc' include 'c1db1.inc' include 'c1db2.inc' include 'c1db3.inc' include 'decomp/decomp.inc' c include 's1dbc.inc' c include 'cgrow.inc' *$reference c + + + LOCAL VARIABLES + + integer je, isr,i c real s11x1, s11x2,s11y1,s11y2,s8x1,s8x2,s8y1,s8y2 c + + + LOCAL VARIABLE DEFINITIONS + + + C + + + functions called + + + integer lentrm c + + + END OF SPECIFICATIONS + + + c data s11x1 /5.0/, s11x2 /20.0/, s11y1 /0.01/ ,s11y2 /0.90/, c & s8x1 /20.0/, s8x2 /80.0/, s8y1 /0.50/, s8y2 /0.95/ c am0cgf = .true. isr = am0csr je = ac0id(isr) close (unit = 31) open (unit = 31,file = rootp(1:lentrm(rootp)) // 'crop.db', & status='old') c read user input data c 500 write(*,*) 'enter the crop number' c je = 4 c read (*,*) je c test for out of range crop numbers if ((je .lt. 1) .or. (je .gt. 35)) then write(*,*) ' crop number ',je,' is not available ' goto 500 end if c write(*,*) 'enter the crop planting date' c read (*,*) jda c write(*,*) 'enter the crop harvest date' c hda = 10 c read (* *) hda c write(*,*) 'enter the ano3' c read (*,*) asmno3(isr) c -----------debug c read crop data base:crop.db do 3 i=1, 8 read (31,*) 3 continue 10 read (31,51) cropnm read(31,*) ac0id(isr), ac0idc(isr), ac0bn1(isr), ac0bn2(isr), & ac0bn3(isr), ac0bp1(isr), ac0bp2(isr), ac0bp3(isr) read(31,*) ac0ck(isr), acrhi(isr), acehu0(isr), aczmxc(isr), & aczmrt(isr), actmin(isr), actopt(isr), ac0bev(isr) read(31,*) ac0fd1(1,isr), ac0fd2(1,isr), ac0fd1(2,isr), & ac0fd2(2,isr), ac0be1(1,isr), ac0be2(1,isr), & ac0be1(2,isr), ac0be2(2,isr) read(31,*) ac0alf(isr), ac0blf(isr), ac0clf(isr), ac0dlf(isr), & ac0arp(isr), ac0brp(isr), ac0crp(isr), ac0drp(isr) read(31,*) ac0aht(isr), ac0bht(isr), ac0ssa(isr), ac0ssb(isr), & ac0sla(isr), ac0hue(isr), ac0lfe(isr), actdtm(isr) read (31,*,err=80) acdkrate(1,isr), acdkrate(2,isr), & acdkrate(3,isr), acdkrate(4,isr), acdkrate(5,isr), & acxstm(isr), acddsthrsh(isr), accovfact(isr) c read(31,*) goto 81 80 write(*,*) 'error reading crop.db file decomp parameters' 81 continue 51 format(a60) if (ac0id(isr) .eq. je) goto 199 goto 10 199 continue c -----------debug c convert sla and ssa to cm^2/plant ac0sla(isr) = ac0sla(isr) * 10. ac0ssa(isr) = ac0ssa(isr) * 10. c 1 format(2i9,6f9.4) c 2 format(8f9.4) c match crop name with crop number (for output only) if (je .eq. 1) ac0nam(isr) = 'alfalfa' if (je .eq. 2) ac0nam(isr) = 'barley' if (je .eq. 3) ac0nam(isr) = 'corn' if (je .eq. 4) ac0nam(isr) = 'cotton - picker' if (je .eq. 5) ac0nam(isr) = 'cotton - stripper' if (je .eq. 6) ac0nam(isr) = 'lentles' if (je .eq. 7) ac0nam(isr) = 'oats' if (je .eq. 8) ac0nam(isr) = 'pasture - spring' if (je .eq. 9) ac0nam(isr) = 'pasture - winter' if (je .eq. 10) ac0nam(isr) = 'peas - winter' if (je .eq. 11) ac0nam(isr) = 'peanuts' if (je .eq. 12) ac0nam(isr) = 'potato' if (je .eq. 13) ac0nam(isr) = 'rice' if (je .eq. 14) ac0nam(isr) = 'sorghum - grain' if (je .eq. 15) ac0nam(isr) = 'sorghum - hay' if (je .eq. 16) ac0nam(isr) = 'soybean' if (je .eq. 17) ac0nam(isr) = 'sunflower' if (je .eq. 18) ac0nam(isr) = 'wheat - duram' if (je .eq. 19) ac0nam(isr) = 'wheat - spring' if (je .eq. 20) ac0nam(isr) = 'wheat - winter' if (je .eq. 21) ac0nam(isr) = 'rye - spring' if (je .eq. 22) ac0nam(isr) = 'rye - winter' if (je .eq. 23) ac0nam(isr) = 'watermelon' if (je .eq. 24) ac0nam(isr) = 'canola - spring' if (je .eq. 25) ac0nam(isr) = 'canola - winter' if (je .eq. 26) ac0nam(isr) = 'sugarbeet -sugar' if (je .eq. 27) ac0nam(isr) = 'sugarbeet - seed' if (je .eq. 28) ac0nam(isr) = 'dry bean' if (je .eq. 29) ac0nam(isr) = 'millet - pearl' if (je .eq. 30) ac0nam(isr) = 'sudangrass' if (je .eq. 31) ac0nam(isr) = 'corn - hay' if (je .eq. 32) ac0nam(isr) = 'oats - winter' if (je .eq. 33) ac0nam(isr) = 'millet - proso' if (je .eq. 34) ac0nam(isr) = 'millet - foxtail' if (je .eq. 35) ac0nam(isr) = 'peas - spring' c write(*,*) cropnm c write(*,*) ac0id(isr), ac0idc(isr), ac0bn1(isr), ac0bn2(isr), c & ac0bn3(isr), ac0bp1(isr), ac0bp2(isr), ac0bp3(isr) c write(*,*) ac0ck(isr), acrhi(isr), acehu0(isr), aczmxc(isr), c & aczmrt(isr), actmin(isr), actopt(isr), ac0bev(isr) c write(*,*) ac0fd1(1,isr), ac0fd2(1,isr), ac0fd1(2,isr), c & ac0fd2(2,isr), ac0be1(1,isr), ac0be2(1,isr), c & ac0be1(2,isr), ac0be2(2,isr) c write(*,*) ac0alf(isr), ac0blf(isr), ac0clf(isr), ac0dlf(isr), c & ac0arp(isr), ac0brp(isr), ac0crp(isr), ac0drp(isr) c write(*,*) ac0aht(isr), ac0bht(isr), ac0ssa(isr), ac0ssb(isr), c & ac0sla(isr), ac0hue(isr), ac0lfe(isr), actdtm(isr) c if (am0cdb.eq.2) then write(60,156) cropnm write(60,157)ac0id(isr), ac0idc(isr), ac0bn1(isr), ac0bn2(isr), & ac0bn3(isr), ac0bp1(isr), ac0bp2(isr), ac0bp3(isr) write(60,158) ac0ck(isr), acrhi(isr), acehu0(isr), aczmxc(isr), & aczmrt(isr), actmin(isr), actopt(isr), ac0bev(isr) write(60,159) ac0fd1(1,isr), ac0fd2(1,isr), ac0fd1(2,isr), & ac0fd2(2,isr), ac0be1(1,isr), ac0be2(1,isr), & ac0be1(2,isr), ac0be2(2,isr) write(60,160)ac0alf(isr), ac0blf(isr), ac0clf(isr), ac0dlf(isr), & ac0arp(isr), ac0brp(isr), ac0crp(isr), ac0drp(isr) write(60,161)ac0aht(isr), ac0bht(isr), ac0ssa(isr), ac0ssb(isr), & ac0sla(isr), ac0hue(isr), ac0lfe(isr), actdtm(isr) 156 format (' crop=',a60) 157 format (' nc=',i3,' idc=',i3,' bn1=',f7.4,' bn2=',f7.4, ' bn3=', &f7.4,' bp1=',f7.4,' bp2=',f7.4,' bp3=',f7.4) 158 format(' ck=',f6.3,' hi=',f6.3,' hui0=',f7.4,' hmx=',f7.4, & ' rdmx=',f7.4,' tbas=',f6.1,' topt=',f6.1,' wavp=',f6.3) 159 format(' frsx1=',f6.1,' frsx2=',f6.1,' frsy1=',f7.4,' frsy2=', & f7.4,' wcx1=',f6.0,' wcx2=',f6.0,' wcy1=',f6.1,' wcy2=',f6.1) 160 format(' a_lf=',f6.3,' b_lf=',f6.3,' c_lf=',f7.4,' d_lf=', & f7.4,' a_rp=',f7.4,' b_rp=',f7.4,' c_rp=',f7.4,' d_rp=',f7.4) 161 format(' a_ht=',f5.2,' b_ht=',f5.2,' ssaa=',f6.2,' ssab=', & f6.2,' sla=',f6.2,' huie=',f7.4,' clfe=',f6.2,' dtm=',i5) endif rewind (unit = 31) return 500 stop end