c   Given a schedule ID such as T4-C3 (coded as 4 3 3),
c   this program produces a detailed description of
c   the steps that this entails.
c
c
c   Steve Verrill, 4/17/01
c
c
c

      integer temp(5,14),depr(6,8)
      integer numstepv(6)
      integer id(6,10,2)

      character*11 step(6,10)

      character*80 argv,intwrite

      character*1 asterisk
       

      data ((temp(i,j),j=1,14),i=1,5)/100,100,110,110,120,120,130,
     x                                130,140,140,150,160,170,180,
     x    105,110,120,120,130,130,140,140,150,150,160,170,180,190,
     x    105,120,130,130,140,140,150,150,160,160,160,170,180,190,
     x    115,130,140,140,150,150,160,160,160,170,170,180,190,200,
     x    120,150,160,180,160,180,160,180,160,180,180,180,190,200/

      data ((depr(i,j),j=1,8),i=1,6)/3,4,5,7,10,15,20,25,
     x4,5,7,10,14,20,30,35,
     x6,8,11,15,20,30,40,50,
     x10,14,19,25,35,50,50,50,
     x25,30,35,40,50,50,50,50,
     x50,50,50,50,50,50,50,50/

      data numstepv/6,6,7,8,9,10/

      data (step(1,j),j=1,6)/"Above 30","30 to 25","25 to 20",
     x                       "20 to 15","15 to 10","10 to final"/
      data (step(2,j),j=1,6)/"Above 35","35 to 30","30 to 25",
     x                       "25 to 20","20 to 15","15 to final"/
      data (step(3,j),j=1,7)/"Above 40","40 to 35","35 to 30",
     x                       "30 to 25","25 to 20","20 to 15",
     x                       "15 to final"/
      data (step(4,j),j=1,8)/"Above 50","50 to 40","40 to 35",
     x                       "35 to 30","30 to 25","25 to 20",
     x                       "20 to 15","15 to final"/
      data (step(5,j),j=1,9)/"Above 60","60 to 50","50 to 40",
     x                       "40 to 35","35 to 30","30 to 25",
     x                       "25 to 20","20 to 15","15 to final"/
      data (step(6,j),j=1,10)/"Above 70","70 to 60","60 to 50",
     x                        "50 to 40","40 to 35","35 to 30",
     x                        "30 to 25","25 to 20","20 to 15",
     x                        "15 to final"/


c  The 3 subscripts of id correspond to "moisture content schedule" 
c  (this takes on values 1 -- 6 corresponding to A -- F),"step in
c  the final drying schedule" (this can take on values 1 -- 10), and
c  "temperature and wbd rows" (the first element is the row in the
c  temperature schedule; the second element is the row in the wet bulb
c  depression schedule).


      data ((id(1,j,k),k=1,2),j=1,6)/1,1,
     x                               2,2,
     x                               3,3,
     x                               4,4,
     x                               5,5,
     x                               5,6/
      data ((id(2,j,k),k=1,2),j=1,6)/1,1,
     x                               1,2,
     x                               2,3,
     x                               3,4,
     x                               4,5,
     x                               5,6/
      data ((id(3,j,k),k=1,2),j=1,7)/1,1,
     x                               1,2,
     x                               1,3,
     x                               2,4,
     x                               3,5,
     x                               4,6,
     x                               5,6/
      data ((id(4,j,k),k=1,2),j=1,8)/1,1,
     x                               1,2,
     x                               1,3,
     x                               1,4,
     x                               2,5,
     x                               3,6,
     x                               4,6,
     x                               5,6/
      data ((id(5,j,k),k=1,2),j=1,9)/1,1,
     x                               1,2,
     x                               1,3,
     x                               1,4,
     x                               1,5,
     x                               2,6,
     x                               3,6,
     x                               4,6,
     x                               5,6/
      data ((id(6,j,k),k=1,2),j=1,10)/1,1,
     x                               1,2,
     x                               1,3,
     x                               1,4,
     x                               1,5,
     x                               1,6,
     x                               2,6,
     x                               3,6,
     x                               4,6,
     x                               5,6/



      asterisk = "*"

      call getarg(1,argv)
      write(intwrite,7) argv
 7    format(a80)
      read(intwrite,*) idt

      call getarg(2,argv)
      write(intwrite,7) argv
      read(intwrite,*) idmc

      call getarg(3,argv)
      write(intwrite,7) argv
      read(intwrite,*) iddepr

      iexit = 0

      if (idt .lt. 1) then

         iexit = 1
         write(6,10) 
 10      format("
Error: The temperature value was below 1.", x " Please contact Steve Verrill at", x ' ', x 'sverrill@fs.fed.us or 608-231-9375.
') endif if (idt .gt. 14) then iexit = 1 write(6,12) 12 format("
Error: The temperature value was greater", x " than 14.", x " Please contact Steve Verrill at", x ' ', x 'sverrill@fs.fed.us or 608-231-9375.
') endif if (idmc .lt. 1) then iexit = 1 write(6,18) 18 format("
Error: The moisture content value was ", x "below 1.", x " Please contact Steve Verrill at", x ' ', x 'sverrill@fs.fed.us or 608-231-9375.
') endif if (idmc .gt. 6) then iexit = 1 write(6,20) 20 format("
Error: The moisture content value was ", x "greater", x " than 6.", x " Please contact Steve Verrill at", x ' ', x 'sverrill@fs.fed.us or 608-231-9375.
') endif if (iddepr .lt. 1) then iexit = 1 write(6,14) 14 format("
Error: The wet bulb depression value was ", x "below 1.", x " Please contact Steve Verrill at", x ' ', x 'sverrill@fs.fed.us or 608-231-9375.
') endif if (iddepr .gt. 8) then iexit = 1 write(6,16) 16 format("
Error: The wet bulb depression value was ", x "greater", x " than 8.", x " Please contact Steve Verrill at", x ' ', x 'sverrill@fs.fed.us or 608-231-9375.
') endif if (iexit .eq. 1) stop c c calculate and write the schedule c c write(6,80) c 80 format('
The step, temp, depr, wbt, emc, rh, ctemp,' c x' cdepr, and cwbt values are:

') write(6,8010) 8010 format("") write(6,8014) 8014 format(" ", x"", x"", x"", x"", x"", x"", x"", x"", x"", x"", x"") numstep = numstepv(idmc) fac = 5.0/9.0 iflagp = 0 do 100 j = 1,numstep itdb = temp(id(idmc,j,1),idt) tdb = itdb iwbd = depr(id(idmc,j,2),iddepr) wbd = iwbd itwb = itdb - iwbd iflag = 0 if (itwb .lt. 90) then iflag = 1 iflagp = 1 itwb = 90 endif twb = itwb call rhemc(tdb,twb,rh,emc) ctdb = (tdb - 32)*fac cdepr = wbd*fac if (iflag .eq. 0) then ctwb = ctdb - cdepr else ctwb = 32.2 endif irh = nint(rh) if (iflag .eq. 0) then write(6,90) j,step(idmc,j),itdb,iwbd,itwb,emc,irh, x ctdb,cdepr,ctwb 90 format(" ") else write(6,95) j,step(idmc,j),itdb,iwbd,itwb, x asterisk,emc,irh, x ctdb,cdepr,ctwb,asterisk 95 format(" ") endif 100 continue write(6,8040) 8040 format("


Step

Moisture
content
Temperature in degrees FEquilibrium
moisture
content

Relative
humidity
Temperature in degrees C
Dry-
bulb
Wet bulb
depression
Wet-
bulb
Dry-
bulb
Wet bulb
depression
Wet-
bulb
",i2,"",a11,"",i3, x "",i2, x "",i3,"",f5.1,"",i2, x "",f5.1,"",f4.1,"",f5.1, x "
",i2,"",a11,"",i3, x "",i2, x "",i3,a1,"",f5.1,"",i2, x "",f5.1,"",f4.1,"",f5.1, x a1,"
") if (iflagp .eq. 1) then write(6,8050) asterisk 8050 format('

',a1,' Wet bulb values below 90 degrees', x ' Fahrenheit are set to 90 degrees.
') endif stop end subroutine rhemc(tdb,twb,rh,emc) c This subroutine calculates relative humidity and c equilibrium moisture content from dry bulb and wet c bulb temperatures. tdb2 = tdb*tdb tdb3 = tdb*tdb2 twb2 = twb*twb twb3 = twb*twb2 c c rh c xlnps = -3.1216 + .04683*twb - (1.033e-4)*twb2 x + (1.3175e-7)*twb3 pswb = exp(xlnps) ys = pswb/(1.61*(29.92 - pswb)) y = ((.24 + .44*ys)*(tdb - twb))/(1094. + .44*tdb - twb) y = ys - y p = (1.61*y*29.92)/(1. + 1.61*y) xlnps = -3.1216 + .04683*tdb - (1.033e-4)*tdb2 x + (1.3175e-7)*tdb3 psdb = exp(xlnps) rh = (p/psdb)*100.0 c c emc c w = 330. + .452*tdb + .00415*tdb2 xk = .791 + (4.63e-4)*tdb - (8.44e-7)*tdb2 xk1 = 6.34 + (7.75e-4)*tdb - (9.35e-5)*tdb2 xk2 = 1.09 + .0284*tdb - (9.04e-5)*tdb2 frh = rh/100.0 term1 = xk1*xk*frh term2 = xk1*xk2*xk*xk*frh*frh x1 = term1 + 2.0*term2 x2 = 1.0 + term1 + term2 emc = xk*frh/(1.0 - xk*frh) + (x1/x2) emc = (1800.0/w)*emc return end