UPP  11.0.0
 All Data Structures Files Functions Variables Pages
UPP_PHYSICS.f
Go to the documentation of this file.
1 
40  module upp_physics
41 
42  implicit none
43 
44  private
45 
46  public :: calcape, calcape2
47  public :: caldiv
48  public :: calgradps
49 
50  public :: calrh
51  public :: calrh_gfs, calrh_gsd, calrh_nam
52  public :: calrh_pw
53  public :: calslr_roebber, calslr_uutah
54  public :: calvor
55 
56  public :: fpvsnew
57  public :: tvirtual
58 
59  contains
60 !
61 !-------------------------------------------------------------------------------------
71 !
72  SUBROUTINE calrh(P1,T1,Q1,RH)
73 
74  use ctlblk_mod, only: ista, iend, jsta, jend, modelname
75  implicit none
76 
77  REAL,dimension(ista:iend,jsta:jend),intent(in) :: p1,t1
78  REAL,dimension(ista:iend,jsta:jend),intent(inout) :: q1
79  REAL,dimension(ista:iend,jsta:jend),intent(out) :: rh
80 
81  IF(modelname == 'RAPR')THEN
82  CALL calrh_gsd(p1,t1,q1,rh)
83  ELSE
84  CALL calrh_nam(p1,t1,q1,rh)
85  END IF
86 
87  END SUBROUTINE calrh
88 !
89 !-------------------------------------------------------------------------------------
90 !
118  SUBROUTINE calrh_nam(P1,T1,Q1,RH)
119  use params_mod, only: pq0, a2, a3, a4, rhmin
120  use ctlblk_mod, only: ista, iend, jsta, jend, spval
121 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
122  implicit none
123 !
124 ! SET PARAMETER.
125 !
126 ! DECLARE VARIABLES.
127 !
128  REAL,dimension(ista:iend,jsta:jend),intent(in) :: p1,t1
129  REAL,dimension(ista:iend,jsta:jend),intent(inout) :: q1
130  REAL,dimension(ista:iend,jsta:jend),intent(out) :: rh
131  REAL qc
132  integer i,j
133 !***************************************************************
134 !
135 ! START CALRH.
136 !
137  DO j=jsta,jend
138  DO i=ista,iend
139  IF (t1(i,j) < spval) THEN
140  IF (abs(p1(i,j)) >= 1) THEN
141  qc = pq0/p1(i,j)*exp(a2*(t1(i,j)-a3)/(t1(i,j)-a4))
142 !
143  rh(i,j) = q1(i,j)/qc
144 !
145 ! BOUNDS CHECK
146 !
147  IF (rh(i,j) > 1.0) THEN
148  rh(i,j) = 1.0
149  q1(i,j) = rh(i,j)*qc
150  ENDIF
151  IF (rh(i,j) < rhmin) THEN !use smaller RH limit for stratosphere
152  rh(i,j) = rhmin
153  q1(i,j) = rh(i,j)*qc
154  ENDIF
155 !
156  ENDIF
157  ELSE
158  rh(i,j) = spval
159  ENDIF
160  ENDDO
161  ENDDO
162 !
163 !
164 ! END SUBROUTINE CALRH
165  END SUBROUTINE calrh_nam
166 !
167 !-------------------------------------------------------------------------------------
168 !
197  SUBROUTINE calrh_gfs(P1,T1,Q1,RH)
198  use params_mod, only: rhmin
199  use ctlblk_mod, only: ista, iend, jsta, jend, spval
200 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
201  implicit none
202 !
203  real,parameter:: con_rd =2.8705e+2 ! gas constant air (J/kg/K)
204  real,parameter:: con_rv =4.6150e+2 ! gas constant H2O
205  real,parameter:: con_eps =con_rd/con_rv
206  real,parameter:: con_epsm1 =con_rd/con_rv-1
207 ! real,external::FPVSNEW
208 
209 ! INTERFACE
210 ! ELEMENTAL FUNCTION FPVSNEW (t)
211 ! REAL FPVSNEW
212 ! REAL, INTENT(IN) :: t
213 ! END FUNCTION FPVSNEW
214 ! END INTERFACE
215 !
216  REAL,dimension(ista:iend,jsta:jend),intent(in) :: p1,t1
217  REAL,dimension(ista:iend,jsta:jend),intent(inout):: q1,rh
218  REAL es,qc
219  integer :: i,j
220 !***************************************************************
221 !
222 ! START CALRH.
223 !
224 !$omp parallel do private(i,j,es,qc)
225  DO j=jsta,jend
226  DO i=ista,iend
227  IF (t1(i,j) < spval .AND. p1(i,j) < spval.AND.q1(i,j)/=spval) THEN
228 ! IF (ABS(P1(I,J)) > 1.0) THEN
229 ! IF (P1(I,J) > 1.0) THEN
230  IF (p1(i,j) >= 1.0) THEN
231  es = min(fpvsnew(t1(i,j)),p1(i,j))
232  qc = con_eps*es/(p1(i,j)+con_epsm1*es)
233 
234 ! QC=PQ0/P1(I,J)*EXP(A2*(T1(I,J)-A3)/(T1(I,J)-A4))
235 
236  rh(i,j) = min(1.0,max(q1(i,j)/qc,rhmin))
237  q1(i,j) = rh(i,j)*qc
238 
239 ! BOUNDS CHECK
240 !
241 ! IF (RH(I,J) > 1.0) THEN
242 ! RH(I,J) = 1.0
243 ! Q1(I,J) = RH(I,J)*QC
244 ! ELSEIF (RH(I,J) < RHmin) THEN !use smaller RH limit for stratosphere
245 ! RH(I,J) = RHmin
246 ! Q1(I,J) = RH(I,J)*QC
247 ! ENDIF
248 
249  ENDIF
250  ELSE
251  rh(i,j) = spval
252  ENDIF
253  ENDDO
254  ENDDO
255 
256  END SUBROUTINE calrh_gfs
257 !
258 !-------------------------------------------------------------------------------------
269 !
270  SUBROUTINE calrh_gsd(P1,T1,Q1,RHB)
271 !
272 
273  use ctlblk_mod, only: ista, iend, jsta, jend, spval
274 
275  implicit none
276 
277  integer :: j, i
278  real :: tx, pol, esx, es, e
279  real, dimension(ista:iend,jsta:jend) :: p1, t1, q1, rhb
280 
281 
282  DO j=jsta,jend
283  DO i=ista,iend
284  IF (t1(i,j) < spval .AND. p1(i,j) < spval .AND. q1(i,j) < spval) THEN
285 ! - compute relative humidity
286  tx=t1(i,j)-273.15
287  pol = 0.99999683 + tx*(-0.90826951e-02 + &
288  tx*(0.78736169e-04 + tx*(-0.61117958e-06 + &
289  tx*(0.43884187e-08 + tx*(-0.29883885e-10 + &
290  tx*(0.21874425e-12 + tx*(-0.17892321e-14 + &
291  tx*(0.11112018e-16 + tx*(-0.30994571e-19)))))))))
292  esx = 6.1078/pol**8
293 
294  es = esx
295  e = p1(i,j)/100.*q1(i,j)/(0.62197+q1(i,j)*0.37803)
296  rhb(i,j) = min(1.,e/es)
297  ELSE
298  rhb(i,j) = spval
299  ENDIF
300  ENDDO
301  ENDDO
302 
303  END SUBROUTINE calrh_gsd
304 !
305 !-------------------------------------------------------------------------------------
306 !
311 
312  SUBROUTINE calrh_pw(RHPW)
313 !
314 !------------------------------------------------------------------
315 !
316 
317  use vrbls3d, only: q, pmid, t
318  use params_mod, only: g
319  use ctlblk_mod, only: lm, ista, iend, jsta, jend, spval
320 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
321  implicit none
322 
323  real,PARAMETER :: svp1=6.1153,svp2=17.67,svp3=29.65
324 
325  REAL, dimension(ista:iend,jsta:jend):: pw, pw_sat, rhpw
326  REAL deltp,sh,qv,temp,es,qs,qv_sat
327  integer i,j,l,k,ka,kb
328 
329  pw = 0.
330  pw_sat = 0.
331  rhpw = 0.
332 
333  DO l=1,lm
334  k=lm-l+1
335  DO j=jsta,jend
336  DO i=ista,iend
337 ! -- use specific humidity for PW calculation
338  if(t(i,j,k)<spval.and.q(i,j,k)<spval) then
339  sh = q(i,j,k)
340  qv = sh/(1.-sh)
341  ka = max(1,k-1)
342  kb = min(lm,k+1)
343 
344 ! assumes that P is in mb at this point - be careful!
345  deltp = 0.5*(pmid(i,j,kb)-pmid(i,j,ka))
346  pw(i,j) = pw(i,j) + sh *deltp/g
347 
348 !Csgb -- Add more for RH w.r.t. PW-sat
349 
350  temp = t(i,j,k)
351 ! --- use saturation mixing ratio w.r.t. water here
352 ! for this check.
353  es = svp1*exp(svp2*(temp-273.15)/(temp-svp3))
354 ! -- get saturation specific humidity (w.r.t. total air)
355  qs = 0.62198*es/(pmid(i,j,k)*1.e-2-0.37802*es)
356 ! -- get saturation mixing ratio (w.r.t. dry air)
357  qv_sat = qs/(1.-qs)
358 
359  pw_sat(i,j) = pw_sat(i,j) + max(sh,qs)*deltp/g
360 
361  if (i==120 .and. j==120 ) &
362  write (6,*)'pw-sat', temp, sh, qs, pmid(i,j,kb) &
363  ,pmid(i,j,ka),pw(i,j),pw_sat(i,j)
364 
365 !sgb - This IS RH w.r.t. PW-sat.
366  rhpw(i,j) = min(1.,pw(i,j) / pw_sat(i,j)) * 100.
367  else
368  rhpw(i,j) = spval
369  endif
370  ENDDO
371  ENDDO
372  ENDDO
373 
374  END SUBROUTINE calrh_pw
375 !
376 !-------------------------------------------------------------------------------------
377 !
378  elemental function fpvsnew(t)
379 
401  implicit none
402  integer,parameter:: nxpvs=7501
403  real,parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt
404  real,parameter:: con_psat =6.1078e+2 ! pres at H2O 3pt
405  real,parameter:: con_cvap =1.8460e+3 ! spec heat H2O gas (J/kg/K)
406  real,parameter:: con_cliq =4.1855e+3 ! spec heat H2O liq
407  real,parameter:: con_hvap =2.5000e+6 ! lat heat H2O cond
408  real,parameter:: con_rv =4.6150e+2 ! gas constant H2O
409  real,parameter:: con_csol =2.1060e+3 ! spec heat H2O ice
410  real,parameter:: con_hfus =3.3358e+5 ! lat heat H2O fusion
411  real,parameter:: tliq=con_ttp
412  real,parameter:: tice=con_ttp-20.0
413  real,parameter:: dldtl=con_cvap-con_cliq
414  real,parameter:: heatl=con_hvap
415  real,parameter:: xponal=-dldtl/con_rv
416  real,parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp)
417  real,parameter:: dldti=con_cvap-con_csol
418  real,parameter:: heati=con_hvap+con_hfus
419  real,parameter:: xponai=-dldti/con_rv
420  real,parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp)
421  real tr,w,pvl,pvi
422  real fpvsnew
423  real,intent(in):: t
424  integer jx
425  real xj,x,tbpvs(nxpvs),xp1
426  real xmin,xmax,xinc,c2xpvs,c1xpvs
427 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
428  xmin=180.0
429  xmax=330.0
430  xinc=(xmax-xmin)/(nxpvs-1)
431 ! c1xpvs=1.-xmin/xinc
432  c2xpvs=1./xinc
433  c1xpvs=1.-xmin*c2xpvs
434 ! xj=min(max(c1xpvs+c2xpvs*t,1.0),real(nxpvs,krealfp))
435  xj=min(max(c1xpvs+c2xpvs*t,1.0),float(nxpvs))
436  jx=min(xj,float(nxpvs)-1.0)
437  x=xmin+(jx-1)*xinc
438 
439  tr=con_ttp/x
440  if(x>=tliq) then
441  tbpvs(jx)=con_psat*(tr**xponal)*exp(xponbl*(1.-tr))
442  elseif(x<tice) then
443  tbpvs(jx)=con_psat*(tr**xponai)*exp(xponbi*(1.-tr))
444  else
445  w=(t-tice)/(tliq-tice)
446  pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr))
447  pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr))
448  tbpvs(jx)=w*pvl+(1.-w)*pvi
449  endif
450 
451  xp1=xmin+(jx-1+1)*xinc
452 
453  tr=con_ttp/xp1
454  if(xp1>=tliq) then
455  tbpvs(jx+1)=con_psat*(tr**xponal)*exp(xponbl*(1.-tr))
456  elseif(xp1<tice) then
457  tbpvs(jx+1)=con_psat*(tr**xponai)*exp(xponbi*(1.-tr))
458  else
459  w=(t-tice)/(tliq-tice)
460  pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr))
461  pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr))
462  tbpvs(jx+1)=w*pvl+(1.-w)*pvi
463  endif
464 
465  fpvsnew=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx))
466 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
467  end function fpvsnew
468 !
469 !-------------------------------------------------------------------------------------
562  SUBROUTINE calcape(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
563  cins,pparc,zeql,thund)
564  use vrbls3d, only: pmid, t, q, zint
565  use vrbls2d, only: teql,ieql
566  use masks, only: lmh
567  use params_mod, only: d00, h1m12, h99999, h10e5, capa, elocp, eps, &
568  oneps, g
569  use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, &
570  plq, ttbl, pl, rdp, the0, sthe, rdthe, ttblq, &
571  itbq, jtbq, rdpq, the0q, stheq, rdtheq
572  use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, me, spval, &
573  ista_2l, iend_2u, ista, iend
574 !
575 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
576  implicit none
577 !
578 ! INCLUDE/SET PARAMETERS. CONSTANTS ARE FROM BOLTON (MWR, 1980).
579  real,PARAMETER :: ismthp=2,ismtht=2,ismthq=2
580 !
581 ! DECLARE VARIABLES.
582 !
583  integer,intent(in) :: itype
584  real,intent(in) :: dpbnd
585  integer, dimension(ista:iend,Jsta:jend),intent(in) :: l1d
586  real, dimension(ista:iend,Jsta:jend),intent(in) :: p1d,t1d
587  real, dimension(ista:iend,jsta:jend),intent(inout) :: q1d,cape,cins,pparc,zeql
588 !
589  integer, dimension(ista:iend,jsta:jend) :: iptb, ithtb, parcel, klres, khres, lcl, idx
590 !
591  real, dimension(ista:iend,jsta:jend) :: thesp, psp, cape20, qq, pp, thund
592  REAL, ALLOCATABLE :: tpar(:,:,:)
593 
594  LOGICAL thunder(ista:iend,jsta:jend), needthun
595  real psfck,pkl,tbtk,qbtk,apebtk,tthbtk,tthk,apespk,tpspk, &
596  bqs00k,sqs00k,bqs10k,sqs10k,bqk,sqk,tqk,presk,gdzkl,thetap, &
597  thetaa,p00k,p10k,p01k,p11k,tthesk,esatp,qsatp,tvp,tv
598 ! real,external :: fpvsnew
599  integer i,j,l,knuml,knumh,lbeg,lend,iq, kb,ittbk
600 
601 ! integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ,IT,LMHK, KB,ITTBK
602 !
603 !**************************************************************
604 ! START CALCAPE HERE.
605 !
606  ALLOCATE(tpar(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
607 !
608 ! COMPUTE CAPE/CINS
609 !
610 ! WHICH IS: THE SUM FROM THE LCL TO THE EQ LEVEL OF
611 ! G * (LN(THETAP) - LN(THETAA)) * DZ
612 !
613 ! (POSITIVE AREA FOR CAPE, NEGATIVE FOR CINS)
614 !
615 ! WHERE:
616 ! THETAP IS THE PARCEL THETA
617 ! THETAA IS THE AMBIENT THETA
618 ! DZ IS THE THICKNESS OF THE LAYER
619 !
620 ! USING LCL AS LEVEL DIRECTLY BELOW SATURATION POINT
621 ! AND EQ LEVEL IS THE HIGHEST POSITIVELY BUOYANT LEVEL.
622 !
623 ! IEQL = EQ LEVEL
624 ! P_thetaemax - real pressure of theta-e max parcel (Pa)
625 !
626 ! INITIALIZE CAPE AND CINS ARRAYS
627 !
628 !$omp parallel do
629  DO j=jsta,jend
630  DO i=ista,iend
631  cape(i,j) = d00
632  cape20(i,j) = d00
633  cins(i,j) = d00
634  lcl(i,j) = 0
635  thesp(i,j) = d00
636  ieql(i,j) = lm
637  parcel(i,j) = lm
638  psp(i,j) = d00
639  pparc(i,j) = d00
640  thunder(i,j) = .true.
641  ENDDO
642  ENDDO
643 !
644 !$omp parallel do
645  DO l=1,lm
646  DO j=jsta,jend
647  DO i=ista,iend
648  tpar(i,j,l) = d00
649  ENDDO
650  ENDDO
651  ENDDO
652 !
653 ! TYPE 2 CAPE/CINS:
654 ! NOTE THAT FOR TYPE 1 CAPE/CINS ARRAYS P1D, T1D, Q1D
655 ! ARE DUMMY ARRAYS.
656 !
657  IF (itype == 2) THEN
658 !$omp parallel do private(i,j)
659  DO j=jsta,jend
660  DO i=ista,iend
661  q1d(i,j) = min(max(h1m12,q1d(i,j)),h99999)
662  ENDDO
663  ENDDO
664  ENDIF
665 !-------FOR ITYPE=1--FIND MAXIMUM THETA E LAYER IN LOWEST DPBND ABOVE GROUND-------
666 !-------FOR ITYPE=2--FIND THETA E LAYER OF GIVEN T1D, Q1D, P1D---------------------
667 !--------------TRIAL MAXIMUM BUOYANCY LEVEL VARIABLES-------------------
668 
669  DO kb=1,lm
670 !hc IF (ITYPE==2.AND.KB>1) cycle
671  IF (itype == 1 .OR. (itype == 2 .AND. kb == 1)) THEN
672 
673 !$omp parallel do private(i,j,apebtk,apespk,bqk,bqs00k,bqs10k,iq,ittbk, &
674 !$omp & p00k,p01k,p10k,p11k,pkl,psfck,qbtk,sqk,sqs00k, &
675 !$omp & sqs10k,tbtk,tpspk,tqk,tthbtk,tthesk,tthk)
676  DO j=jsta,jend
677  DO i=ista,iend
678  psfck = pmid(i,j,nint(lmh(i,j)))
679  pkl = pmid(i,j,kb)
680  IF(psfck<spval.and.pkl<spval)THEN
681 
682 !hc IF (ITYPE==1.AND.(PKL<PSFCK-DPBND.OR.PKL>PSFCK)) cycle
683  IF (itype ==2 .OR. &
684  (itype == 1 .AND. (pkl >= psfck-dpbnd .AND. pkl <= psfck)))THEN
685  IF (itype == 1) THEN
686  tbtk = t(i,j,kb)
687  qbtk = max(0.0, q(i,j,kb))
688  apebtk = (h10e5/pkl)**capa
689  ELSE
690  pkl = p1d(i,j)
691  tbtk = t1d(i,j)
692  qbtk = max(0.0, q1d(i,j))
693  apebtk = (h10e5/pkl)**capa
694  ENDIF
695 
696 !----------Breogan Gomez - 2009-02-06
697 ! To prevent QBTK to be less than 0 which leads to a unrealistic value of PRESK
698 ! and a floating invalid.
699 
700 ! if(QBTK < 0) QBTK = 0
701 
702 !--------------SCALING POTENTIAL TEMPERATURE & TABLE INDEX--------------
703  tthbtk = tbtk*apebtk
704  tthk = (tthbtk-thl)*rdth
705  qq(i,j) = tthk - aint(tthk)
706  ittbk = int(tthk) + 1
707 !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
708  IF(ittbk < 1) THEN
709  ittbk = 1
710  qq(i,j) = d00
711  ENDIF
712  IF(ittbk >= jtb) THEN
713  ittbk = jtb-1
714  qq(i,j) = d00
715  ENDIF
716 !--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY---------------
717  bqs00k = qs0(ittbk)
718  sqs00k = sqs(ittbk)
719  bqs10k = qs0(ittbk+1)
720  sqs10k = sqs(ittbk+1)
721 !--------------SCALING SPEC. HUMIDITY & TABLE INDEX---------------------
722  bqk = (bqs10k-bqs00k)*qq(i,j) + bqs00k
723  sqk = (sqs10k-sqs00k)*qq(i,j) + sqs00k
724  tqk = (qbtk-bqk)/sqk*rdq
725  pp(i,j) = tqk-aint(tqk)
726  iq = int(tqk)+1
727 !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
728  IF(iq < 1) THEN
729  iq = 1
730  pp(i,j) = d00
731  ENDIF
732  IF(iq >= itb) THEN
733  iq = itb-1
734  pp(i,j) = d00
735  ENDIF
736 !--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.-------
737  p00k = ptbl(iq ,ittbk )
738  p10k = ptbl(iq+1,ittbk )
739  p01k = ptbl(iq ,ittbk+1)
740  p11k = ptbl(iq+1,ittbk+1)
741 !--------------SATURATION POINT VARIABLES AT THE BOTTOM-----------------
742  tpspk = p00k + (p10k-p00k)*pp(i,j) + (p01k-p00k)*qq(i,j) &
743  + (p00k-p10k-p01k+p11k)*pp(i,j)*qq(i,j)
744 
745 !!from WPP::tgs APESPK=(H10E5/TPSPK)**CAPA
746  if (tpspk > 1.0e-3) then
747  apespk = (max(0.,h10e5/ tpspk))**capa
748  else
749  apespk = 0.0
750  endif
751 
752  tthesk = tthbtk * exp(elocp*qbtk*apespk/tthbtk)
753 !--------------CHECK FOR MAXIMUM THETA E--------------------------------
754  IF(tthesk > thesp(i,j)) THEN
755  psp(i,j) = tpspk
756  thesp(i,j) = tthesk
757  parcel(i,j) = kb
758  ENDIF
759  END IF
760  ENDIF !end PSFCK<spval.and.PKL<spval
761  ENDDO ! I loop
762  ENDDO ! J loop
763  END IF
764  ENDDO ! KB loop
765 
766 !----FIND THE PRESSURE OF THE PARCEL THAT WAS LIFTED
767 !$omp parallel do private(i,j)
768  DO j=jsta,jend
769  DO i=ista,iend
770  pparc(i,j) = pmid(i,j,parcel(i,j))
771  ENDDO
772  ENDDO
773 !
774 !-----CHOOSE LAYER DIRECTLY BELOW PSP AS LCL AND------------------------
775 !-----ENSURE THAT THE LCL IS ABOVE GROUND.------------------------------
776 !-------(IN SOME RARE CASES FOR ITYPE=2, IT IS NOT)---------------------
777  DO l=1,lm
778 !$omp parallel do private(i,j)
779  DO j=jsta,jend
780  DO i=ista,iend
781  IF (pmid(i,j,l) < psp(i,j)) lcl(i,j) = l+1
782  ENDDO
783  ENDDO
784  ENDDO
785 !$omp parallel do private(i,j)
786  DO j=jsta,jend
787  DO i=ista,iend
788  IF (lcl(i,j) > nint(lmh(i,j))) lcl(i,j) = nint(lmh(i,j))
789  IF (itype > 2) THEN
790  IF (t(i,j,lcl(i,j)) < 263.15) THEN
791  thunder(i,j) = .false.
792  ENDIF
793  ENDIF
794  ENDDO
795  ENDDO
796 !-----------------------------------------------------------------------
797 !---------FIND TEMP OF PARCEL LIFTED ALONG MOIST ADIABAT (TPAR)---------
798 !-----------------------------------------------------------------------
799 
800  DO l=lm,1,-1
801 !--------------SCALING PRESSURE & TT TABLE INDEX------------------------
802  knuml = 0
803  knumh = 0
804  DO j=jsta,jend
805  DO i=ista,iend
806  klres(i,j) = 0
807  khres(i,j) = 0
808  IF(l <= lcl(i,j)) THEN
809  IF(pmid(i,j,l) < plq)THEN
810  knuml = knuml + 1
811  klres(i,j) = 1
812  ELSE
813  knumh = knumh + 1
814  khres(i,j) = 1
815  ENDIF
816  ENDIF
817  ENDDO
818  ENDDO
819 !***
820 !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE<PLQ
821 !**
822  IF(knuml > 0) THEN
823  CALL ttblex(tpar(ista_2l,jsta_2l,l),ttbl,itb,jtb,klres &
824  , pmid(ista_2l,jsta_2l,l),pl,qq,pp,rdp,the0,sthe &
825  , rdthe,thesp,iptb,ithtb)
826  ENDIF
827 !***
828 !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ
829 !**
830  IF(knumh > 0) THEN
831  CALL ttblex(tpar(ista_2l,jsta_2l,l),ttblq,itbq,jtbq,khres &
832  , pmid(ista_2l,jsta_2l,l),plq,qq,pp,rdpq &
833  ,the0q,stheq,rdtheq,thesp,iptb,ithtb)
834  ENDIF
835 
836 !------------SEARCH FOR EQ LEVEL----------------------------------------
837 !$omp parallel do private(i,j)
838  DO j=jsta,jend
839  DO i=ista,iend
840  IF(khres(i,j) > 0) THEN
841  IF(tpar(i,j,l) > t(i,j,l)) ieql(i,j) = l
842  ENDIF
843  ENDDO
844  ENDDO
845 !
846 !$omp parallel do private(i,j)
847  DO j=jsta,jend
848  DO i=ista,iend
849  IF(klres(i,j) > 0) THEN
850  IF(tpar(i,j,l) > t(i,j,l) .AND. &
851  pmid(i,j,l)>100.) ieql(i,j) = l
852  ENDIF
853  ENDDO
854  ENDDO
855 !-----------------------------------------------------------------------
856  ENDDO ! end of do l=lm,1,-1 loop
857 !------------COMPUTE CAPE AND CINS--------------------------------------
858  lbeg = 1000
859  lend = 0
860  DO j=jsta,jend
861  DO i=ista,iend
862  lbeg = min(ieql(i,j),lbeg)
863  lend = max(lcl(i,j),lend)
864  ENDDO
865  ENDDO
866 !
867 !$omp parallel do private(i,j)
868  DO j=jsta,jend
869  DO i=ista,iend
870  IF(t(i,j,ieql(i,j)) > 255.65) THEN
871  thunder(i,j) = .false.
872  ENDIF
873  ENDDO
874  ENDDO
875 !
876  DO l=lbeg,lend
877 
878 !$omp parallel do private(i,j)
879  DO j=jsta,jend
880  DO i=ista,iend
881  idx(i,j) = 0
882  IF(l >= ieql(i,j).AND.l <= lcl(i,j)) THEN
883  idx(i,j) = 1
884  ENDIF
885  ENDDO
886  ENDDO
887 !
888 !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv)
889  DO j=jsta,jend
890  DO i=ista,iend
891  IF(idx(i,j) > 0) THEN
892  presk = pmid(i,j,l)
893  gdzkl = (zint(i,j,l)-zint(i,j,l+1)) * g
894  esatp = min(fpvsnew(tpar(i,j,l)),presk)
895  qsatp = eps*esatp/(presk-esatp*oneps)
896 ! TVP = TPAR(I,J,L)*(1+0.608*QSATP)
897  tvp = tvirtual(tpar(i,j,l),qsatp)
898  thetap = tvp*(h10e5/presk)**capa
899 ! TV = T(I,J,L)*(1+0.608*Q(I,J,L))
900  tv = tvirtual(t(i,j,l),q(i,j,l))
901  thetaa = tv*(h10e5/presk)**capa
902  IF(thetap < thetaa) THEN
903  cins(i,j) = cins(i,j) + (log(thetap)-log(thetaa))*gdzkl
904  ELSEIF(thetap > thetaa) THEN
905  cape(i,j) = cape(i,j) + (log(thetap)-log(thetaa))*gdzkl
906  IF (thunder(i,j) .AND. t(i,j,l) < 273.15 &
907  .AND. t(i,j,l) > 253.15) THEN
908  cape20(i,j) = cape20(i,j) + (log(thetap)-log(thetaa))*gdzkl
909  ENDIF
910  ENDIF
911  ENDIF
912  ENDDO
913  ENDDO
914  ENDDO
915 !
916 ! ENFORCE LOWER LIMIT OF 0.0 ON CAPE AND UPPER
917 ! LIMIT OF 0.0 ON CINS.
918 !
919 !$omp parallel do private(i,j)
920  DO j=jsta,jend
921  DO i=ista,iend
922  cape(i,j) = max(d00,cape(i,j))
923  cins(i,j) = min(cins(i,j),d00)
924 ! add equillibrium height
925  zeql(i,j) = zint(i,j,ieql(i,j))
926  teql(i,j) = t(i,j,ieql(i,j))
927  IF (cape20(i,j) < 75.) THEN
928  thunder(i,j) = .false.
929  ENDIF
930  IF (thunder(i,j)) THEN
931  thund(i,j) = 1.0
932  ELSE
933  thund(i,j) = 0.0
934  ENDIF
935  ENDDO
936  ENDDO
937 !
938  DEALLOCATE(tpar)
939 !
940  END SUBROUTINE calcape
941 !
942 !-------------------------------------------------------------------------------------
1040  SUBROUTINE calcape2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
1041  cape,cins,lfc,esrhl,esrhh, &
1042  dcape,dgld,esp)
1043  use vrbls3d, only: pmid, t, q, zint
1044  use vrbls2d, only: fis,ieql
1045  use gridspec_mod, only: gridtype
1046  use masks, only: lmh
1047  use params_mod, only: d00, h1m12, h99999, h10e5, capa, elocp, eps, &
1048  oneps, g, tfrz
1049  use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, &
1050  plq, ttbl, pl, rdp, the0, sthe, rdthe, ttblq, &
1051  itbq, jtbq, rdpq, the0q, stheq, rdtheq
1052  use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, jm, me, jsta_m, jend_m, spval,&
1053  ista_2l, iend_2u, ista, iend, ista_m, iend_m
1054 !
1055 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1056  implicit none
1057 !
1058 ! INCLUDE/SET PARAMETERS. CONSTANTS ARE FROM BOLTON (MWR, 1980).
1059  real,PARAMETER :: ismthp=2,ismtht=2,ismthq=2
1060 !
1061 ! DECLARE VARIABLES.
1062 !
1063  integer,intent(in) :: itype
1064  real,intent(in) :: dpbnd
1065  integer, dimension(ista:iend,Jsta:jend),intent(in) :: l1d
1066  real, dimension(ista:iend,Jsta:jend),intent(in) :: p1d,t1d
1067 ! real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL
1068  real, dimension(ista:iend,jsta:jend),intent(inout) :: q1d,cape,cins
1069  real, dimension(ista:iend,jsta:jend) :: pparc,zeql
1070  real, dimension(ista:iend,jsta:jend),intent(inout) :: lfc,esrhl,esrhh
1071  real, dimension(ista:iend,jsta:jend),intent(inout) :: dcape,dgld,esp
1072  integer, dimension(ista:iend,jsta:jend) ::l12,l17,l3km
1073 !
1074  integer, dimension(ista:iend,jsta:jend) :: iptb, ithtb, parcel, klres, khres, lcl, idx
1075 !
1076  real, dimension(ista:iend,jsta:jend) :: thesp, psp, cape20, qq, pp, thund
1077  integer, dimension(ista:iend,jsta:jend) :: parcel2
1078  real, dimension(ista:iend,jsta:jend) :: thesp2,psp2
1079  real, dimension(ista:iend,jsta:jend) :: cape4,cins4
1080  REAL, ALLOCATABLE :: tpar(:,:,:)
1081  REAL, ALLOCATABLE :: tpar2(:,:,:)
1082 
1083  LOGICAL thunder(ista:iend,jsta:jend), needthun
1084  real psfck,pkl,tbtk,qbtk,apebtk,tthbtk,tthk,apespk,tpspk, &
1085  bqs00k,sqs00k,bqs10k,sqs10k,bqk,sqk,tqk,presk,gdzkl,thetap, &
1086  thetaa,p00k,p10k,p01k,p11k,tthesk,esatp,qsatp,tvp,tv
1087  real presk2, esatp2, qsatp2, tvp2, thetap2, tv2, thetaa2
1088 ! real,external :: fpvsnew
1089  integer i,j,l,knuml,knumh,lbeg,lend,iq, kb,ittbk
1090  integer ie,iw,jn,js,ive(jm),ivw(jm),jvn,jvs
1091  integer istart,istop,jstart,jstop
1092  real, dimension(ista:iend,jsta:jend) :: htsfc
1093 
1094 ! integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ,IT,LMHK, KB,ITTBK
1095 !
1096 !**************************************************************
1097 ! START CALCAPE HERE.
1098 !
1099  ALLOCATE(tpar(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
1100  ALLOCATE(tpar2(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
1101 !
1102 ! COMPUTE CAPE/CINS
1103 !
1104 ! WHICH IS: THE SUM FROM THE LCL TO THE EQ LEVEL OF
1105 ! G * (LN(THETAP) - LN(THETAA)) * DZ
1106 !
1107 ! (POSITIVE AREA FOR CAPE, NEGATIVE FOR CINS)
1108 !
1109 ! WHERE:
1110 ! THETAP IS THE PARCEL THETA
1111 ! THETAA IS THE AMBIENT THETA
1112 ! DZ IS THE THICKNESS OF THE LAYER
1113 !
1114 ! USING LCL AS LEVEL DIRECTLY BELOW SATURATION POINT
1115 ! AND EQ LEVEL IS THE HIGHEST POSITIVELY BUOYANT LEVEL.
1116 !
1117 ! IEQL = EQ LEVEL
1118 ! P_thetaemax - real pressure of theta-e max parcel (Pa)
1119 !
1120 ! INITIALIZE CAPE AND CINS ARRAYS
1121 !
1122 !$omp parallel do
1123  DO j=jsta,jend
1124  DO i=ista,iend
1125  cape(i,j) = d00
1126  cape20(i,j) = d00
1127  cape4(i,j) = d00
1128  cins(i,j) = d00
1129  cins4(i,j) = d00
1130  lcl(i,j) = 0
1131  thesp(i,j) = d00
1132  ieql(i,j) = lm
1133  parcel(i,j) = lm
1134  psp(i,j) = d00
1135  pparc(i,j) = d00
1136  thunder(i,j) = .true.
1137  lfc(i,j) = d00
1138  esrhl(i,j) = d00
1139  esrhh(i,j) = d00
1140  dcape(i,j) = d00
1141  dgld(i,j) = d00
1142  esp(i,j) = d00
1143  thesp2(i,j) = 1000.
1144  psp2(i,j) = d00
1145  parcel2(i,j) = lm
1146  ENDDO
1147  ENDDO
1148 !
1149 !$omp parallel do
1150  DO l=1,lm
1151  DO j=jsta,jend
1152  DO i=ista,iend
1153  tpar(i,j,l) = d00
1154  tpar2(i,j,l) = d00
1155  ENDDO
1156  ENDDO
1157  ENDDO
1158 !
1159 ! FIND SURFACE HEIGHT
1160 !
1161  IF(gridtype == 'E')THEN
1162  jvn = 1
1163  jvs = -1
1164  do j=jsta,jend
1165  ive(j) = mod(j,2)
1166  ivw(j) = ive(j)-1
1167  enddo
1168  istart = ista_m
1169  istop = iend_m
1170  jstart = jsta_m
1171  jstop = jend_m
1172  ELSE IF(gridtype == 'B')THEN
1173  jvn = 1
1174  jvs = 0
1175  do j=jsta,jend
1176  ive(j)=1
1177  ivw(j)=0
1178  enddo
1179  istart = ista_m
1180  istop = iend_m
1181  jstart = jsta_m
1182  jstop = jend_m
1183  ELSE
1184  jvn = 0
1185  jvs = 0
1186  do j=jsta,jend
1187  ive(j) = 0
1188  ivw(j) = 0
1189  enddo
1190  istart = ista
1191  istop = iend
1192  jstart = jsta
1193  jstop = jend
1194  END IF
1195 !!$omp parallel do private(htsfc,ie,iw)
1196  IF(gridtype /= 'A') CALL exch(fis(ista:iend,jsta:jend))
1197  DO j=jstart,jstop
1198  DO i=istart,istop
1199  ie = i+ive(j)
1200  iw = i+ivw(j)
1201  jn = j+jvn
1202  js = j+jvs
1203 !mp PDSLVK=(PD(IW,J)*RES(IW,J)+PD(IE,J)*RES(IE,J)+
1204 !mp 1 PD(I,J+1)*RES(I,J+1)+PD(I,J-1)*RES(I,J-1))*0.25
1205 !mp PSFCK=AETA(LMV(I,J))*PDSLVK+PT
1206  IF (gridtype=='B')THEN
1207  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))
1208  ELSE
1209  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))
1210  ENDIF
1211  ENDDO
1212  ENDDO
1213 !
1214 ! TYPE 2 CAPE/CINS:
1215 ! NOTE THAT FOR TYPE 1 CAPE/CINS ARRAYS P1D, T1D, Q1D
1216 ! ARE DUMMY ARRAYS.
1217 !
1218  IF (itype == 2) THEN
1219 !$omp parallel do private(i,j)
1220  DO j=jsta,jend
1221  DO i=ista,iend
1222  q1d(i,j) = min(max(h1m12,q1d(i,j)),h99999)
1223  ENDDO
1224  ENDDO
1225  ENDIF
1226 !-------FOR ITYPE=1--FIND MAXIMUM THETA E LAYER IN LOWEST DPBND ABOVE GROUND-------
1227 !-------FOR ITYPE=2--FIND THETA E LAYER OF GIVEN T1D, Q1D, P1D---------------------
1228 !--------------TRIAL MAXIMUM BUOYANCY LEVEL VARIABLES-------------------
1229 
1230  DO kb=1,lm
1231 !hc IF (ITYPE==2.AND.KB>1) cycle
1232  IF (itype == 1 .OR. (itype == 2 .AND. kb == 1)) THEN
1233 
1234 !$omp parallel do private(i,j,apebtk,apespk,bqk,bqs00k,bqs10k,iq,ittbk, &
1235 !$omp & p00k,p01k,p10k,p11k,pkl,psfck,qbtk,sqk,sqs00k, &
1236 !$omp & sqs10k,tbtk,tpspk,tqk,tthbtk,tthesk,tthk)
1237  DO j=jsta,jend
1238  DO i=ista,iend
1239  psfck = pmid(i,j,nint(lmh(i,j)))
1240  pkl = pmid(i,j,kb)
1241 
1242 !hc IF (ITYPE==1.AND.(PKL<PSFCK-DPBND.OR.PKL>PSFCK)) cycle
1243  IF (itype ==2 .OR. &
1244  (itype == 1 .AND. (pkl >= psfck-dpbnd .AND. pkl <= psfck)))THEN
1245  IF (itype == 1) THEN
1246  tbtk = t(i,j,kb)
1247  qbtk = max(0.0, q(i,j,kb))
1248  apebtk = (h10e5/pkl)**capa
1249  ELSE
1250  pkl = p1d(i,j)
1251  tbtk = t1d(i,j)
1252  qbtk = max(0.0, q1d(i,j))
1253  apebtk = (h10e5/pkl)**capa
1254  ENDIF
1255 
1256 !----------Breogan Gomez - 2009-02-06
1257 ! To prevent QBTK to be less than 0 which leads to a unrealistic value of PRESK
1258 ! and a floating invalid.
1259 
1260 ! if(QBTK < 0) QBTK = 0
1261 
1262 !--------------SCALING POTENTIAL TEMPERATURE & TABLE INDEX--------------
1263  tthbtk = tbtk*apebtk
1264  tthk = (tthbtk-thl)*rdth
1265  qq(i,j) = tthk - aint(tthk)
1266  ittbk = int(tthk) + 1
1267 !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
1268  IF(ittbk < 1) THEN
1269  ittbk = 1
1270  qq(i,j) = d00
1271  ENDIF
1272  IF(ittbk >= jtb) THEN
1273  ittbk = jtb-1
1274  qq(i,j) = d00
1275  ENDIF
1276 !--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY---------------
1277  bqs00k = qs0(ittbk)
1278  sqs00k = sqs(ittbk)
1279  bqs10k = qs0(ittbk+1)
1280  sqs10k = sqs(ittbk+1)
1281 !--------------SCALING SPEC. HUMIDITY & TABLE INDEX---------------------
1282  bqk = (bqs10k-bqs00k)*qq(i,j) + bqs00k
1283  sqk = (sqs10k-sqs00k)*qq(i,j) + sqs00k
1284  tqk = (qbtk-bqk)/sqk*rdq
1285  pp(i,j) = tqk-aint(tqk)
1286  iq = int(tqk)+1
1287 !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
1288  IF(iq < 1) THEN
1289  iq = 1
1290  pp(i,j) = d00
1291  ENDIF
1292  IF(iq >= itb) THEN
1293  iq = itb-1
1294  pp(i,j) = d00
1295  ENDIF
1296 !--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.-------
1297  p00k = ptbl(iq ,ittbk )
1298  p10k = ptbl(iq+1,ittbk )
1299  p01k = ptbl(iq ,ittbk+1)
1300  p11k = ptbl(iq+1,ittbk+1)
1301 !--------------SATURATION POINT VARIABLES AT THE BOTTOM-----------------
1302  tpspk = p00k + (p10k-p00k)*pp(i,j) + (p01k-p00k)*qq(i,j) &
1303  + (p00k-p10k-p01k+p11k)*pp(i,j)*qq(i,j)
1304 
1305 !!from WPP::tgs APESPK=(H10E5/TPSPK)**CAPA
1306  if (tpspk > 1.0e-3) then
1307  apespk = (max(0.,h10e5/ tpspk))**capa
1308  else
1309  apespk = 0.0
1310  endif
1311 
1312  tthesk = tthbtk * exp(elocp*qbtk*apespk/tthbtk)
1313 !--------------CHECK FOR MAXIMUM THETA E--------------------------------
1314  IF(tthesk > thesp(i,j)) THEN
1315  psp(i,j) = tpspk
1316  thesp(i,j) = tthesk
1317  parcel(i,j) = kb
1318  ENDIF
1319 !--------------CHECK FOR MINIMUM THETA E--------------------------------
1320  IF(tthesk < thesp2(i,j)) THEN
1321  psp2(i,j) = tpspk
1322  thesp2(i,j) = tthesk
1323  parcel2(i,j) = kb
1324  ENDIF
1325  END IF
1326  ENDDO ! I loop
1327  ENDDO ! J loop
1328  END IF
1329  ENDDO ! KB loop
1330 
1331 !----FIND THE PRESSURE OF THE PARCEL THAT WAS LIFTED
1332 !$omp parallel do private(i,j)
1333  DO j=jsta,jend
1334  DO i=ista,iend
1335  pparc(i,j) = pmid(i,j,parcel(i,j))
1336  ENDDO
1337  ENDDO
1338 !
1339 !-----CHOOSE LAYER DIRECTLY BELOW PSP AS LCL AND------------------------
1340 !-----ENSURE THAT THE LCL IS ABOVE GROUND.------------------------------
1341 !-------(IN SOME RARE CASES FOR ITYPE=2, IT IS NOT)---------------------
1342  DO l=1,lm
1343 !$omp parallel do private(i,j)
1344  DO j=jsta,jend
1345  DO i=ista,iend
1346  IF (pmid(i,j,l) < psp(i,j)) lcl(i,j) = l+1
1347  ENDDO
1348  ENDDO
1349  ENDDO
1350 !$omp parallel do private(i,j)
1351  DO j=jsta,jend
1352  DO i=ista,iend
1353  IF (lcl(i,j) > nint(lmh(i,j))) lcl(i,j) = nint(lmh(i,j))
1354  IF (itype > 2) THEN
1355  IF (t(i,j,lcl(i,j)) < 263.15) THEN
1356  thunder(i,j) = .false.
1357  ENDIF
1358  ENDIF
1359 
1360  ! Limit LCL to prevent out-of-bounds accesses later
1361  lcl(i,j) = max(min(lcl(i,j),lm-1),1)
1362  ENDDO
1363  ENDDO
1364 !-----------------------------------------------------------------------
1365 !---------FIND TEMP OF PARCEL LIFTED ALONG MOIST ADIABAT (TPAR)---------
1366 !-----------------------------------------------------------------------
1367  DO l=lm,1,-1
1368 !--------------SCALING PRESSURE & TT TABLE INDEX------------------------
1369  knuml = 0
1370  knumh = 0
1371  DO j=jsta,jend
1372  DO i=ista,iend
1373  klres(i,j) = 0
1374  khres(i,j) = 0
1375  IF(l <= lcl(i,j)) THEN
1376  IF(pmid(i,j,l) < plq)THEN
1377  knuml = knuml + 1
1378  klres(i,j) = 1
1379  ELSE
1380  knumh = knumh + 1
1381  khres(i,j) = 1
1382  ENDIF
1383  ENDIF
1384  ENDDO
1385  ENDDO
1386 !***
1387 !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE<PLQ
1388 !**
1389  IF(knuml > 0) THEN
1390  CALL ttblex(tpar(ista_2l,jsta_2l,l),ttbl,itb,jtb,klres &
1391  , pmid(ista_2l,jsta_2l,l),pl,qq,pp,rdp,the0,sthe &
1392  , rdthe,thesp,iptb,ithtb)
1393  ENDIF
1394 !***
1395 !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ
1396 !**
1397  IF(knumh > 0) THEN
1398  CALL ttblex(tpar(ista_2l,jsta_2l,l),ttblq,itbq,jtbq,khres &
1399  , pmid(ista_2l,jsta_2l,l),plq,qq,pp,rdpq &
1400  ,the0q,stheq,rdtheq,thesp,iptb,ithtb)
1401  ENDIF
1402 
1403 !------------SEARCH FOR EQ LEVEL----------------------------------------
1404 !$omp parallel do private(i,j)
1405  DO j=jsta,jend
1406  DO i=ista,iend
1407  IF(khres(i,j) > 0) THEN
1408  IF(tpar(i,j,l) > t(i,j,l)) ieql(i,j) = l
1409  ENDIF
1410  ENDDO
1411  ENDDO
1412 !
1413 !$omp parallel do private(i,j)
1414  DO j=jsta,jend
1415  DO i=ista,iend
1416  IF(klres(i,j) > 0) THEN
1417  IF(tpar(i,j,l) > t(i,j,l)) ieql(i,j) = l
1418  ENDIF
1419  ENDDO
1420  ENDDO
1421 !-----------------------------------------------------------------------
1422  ENDDO ! end of do l=lm,1,-1 loop
1423 !------------COMPUTE CAPE AND CINS--------------------------------------
1424  lbeg = 1000
1425  lend = 0
1426  DO j=jsta,jend
1427  DO i=ista,iend
1428  lbeg = min(ieql(i,j),lbeg)
1429  lend = max(lcl(i,j),lend)
1430  ENDDO
1431  ENDDO
1432 !
1433 !$omp parallel do private(i,j)
1434  DO j=jsta,jend
1435  DO i=ista,iend
1436  IF(t(i,j,ieql(i,j)) > 255.65) THEN
1437  thunder(i,j) = .false.
1438  ENDIF
1439  ENDDO
1440  ENDDO
1441 !
1442 !Ensure later calculations do not access LM+1
1443 !
1444  lend=min(lend,lm-1)
1445 !
1446 !reverse L order from bottom up for ESRH calculation
1447 !
1448  esrhh = lcl
1449  esrhl = lcl
1450 ! DO L=LBEG,LEND
1451  DO l=lend,lbeg,-1
1452 
1453 !$omp parallel do private(i,j)
1454  DO j=jsta,jend
1455  DO i=ista,iend
1456  idx(i,j) = 0
1457  IF(l >= ieql(i,j).AND.l <= lcl(i,j)) THEN
1458  idx(i,j) = 1
1459  ENDIF
1460  ENDDO
1461  ENDDO
1462 !
1463 !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv,&
1464 !$omp & presk2,esatp2,qsatp2,tvp2,thetap2,tv2,thetaa2)
1465  DO j=jsta,jend
1466  DO i=ista,iend
1467  IF(idx(i,j) > 0) THEN
1468  presk = pmid(i,j,l)
1469  gdzkl = (zint(i,j,l)-zint(i,j,l+1)) * g
1470  esatp = min(fpvsnew(tpar(i,j,l)),presk)
1471  qsatp = eps*esatp/(presk-esatp*oneps)
1472 ! TVP = TPAR(I,J,L)*(1+0.608*QSATP)
1473  tvp = tvirtual(tpar(i,j,l),qsatp)
1474  thetap = tvp*(h10e5/presk)**capa
1475 ! TV = T(I,J,L)*(1+0.608*Q(I,J,L))
1476  tv = tvirtual(t(i,j,l),q(i,j,l))
1477  thetaa = tv*(h10e5/presk)**capa
1478  IF(thetap < thetaa) THEN
1479  cins4(i,j) = cins4(i,j) + (log(thetap)-log(thetaa))*gdzkl
1480  IF(zint(i,j,l)-htsfc(i,j) <= 3000.) THEN
1481  cins(i,j) = cins(i,j) + (log(thetap)-log(thetaa))*gdzkl
1482  ENDIF
1483  ELSEIF(thetap > thetaa) THEN
1484  cape4(i,j) = cape4(i,j) + (log(thetap)-log(thetaa))*gdzkl
1485  IF(zint(i,j,l)-htsfc(i,j) <= 3000.) THEN
1486  cape(i,j) = cape(i,j) + (log(thetap)-log(thetaa))*gdzkl
1487  ENDIF
1488  IF (thunder(i,j) .AND. t(i,j,l) < 273.15 &
1489  .AND. t(i,j,l) > 253.15) THEN
1490  cape20(i,j) = cape20(i,j) + (log(thetap)-log(thetaa))*gdzkl
1491  ENDIF
1492  ENDIF
1493 
1494 ! LFC
1495  IF (itype /= 1) THEN
1496  presk2 = pmid(i,j,l+1)
1497  esatp2 = min(fpvsnew(tpar(i,j,l+1)),presk2)
1498  qsatp2 = eps*esatp2/(presk2-esatp2*oneps)
1499 ! TVP2 = TPAR(I,J,L+1)*(1+0.608*QSATP2)
1500  tvp2 = tvirtual(tpar(i,j,l+1),qsatp2)
1501  thetap2 = tvp2*(h10e5/presk2)**capa
1502 ! TV2 = T(I,J,L+1)*(1+0.608*Q(I,J,L+1))
1503  tv2 = tvirtual(t(i,j,l+1),q(i,j,l+1))
1504  thetaa2 = tv2*(h10e5/presk2)**capa
1505  IF(thetap >= thetaa .AND. thetap2 <= thetaa2) THEN
1506  IF(lfc(i,j) == d00)THEN
1507  lfc(i,j) = zint(i,j,l)
1508  ENDIF
1509  ENDIF
1510  ENDIF
1511 !
1512 ! ESRH/CAPE threshold check
1513  IF(zint(i,j,l)-htsfc(i,j) <= 3000.) THEN
1514  IF(cape4(i,j) >= 100. .AND. cins4(i,j) >= -250.) THEN
1515  IF(esrhl(i,j) == lcl(i,j)) esrhl(i,j)=l
1516  ENDIF
1517  esrhh(i,j)=l
1518  ENDIF
1519 
1520  ENDIF !(IDX(I,J) > 0)
1521  ENDDO
1522  ENDDO
1523  ENDDO
1524 
1525 !$omp parallel do private(i,j)
1526  DO j=jsta,jend
1527  DO i=ista,iend
1528  IF(esrhh(i,j) > esrhl(i,j)) esrhh(i,j)=ieql(i,j)
1529  ENDDO
1530  ENDDO
1531 !
1532 ! ENFORCE LOWER LIMIT OF 0.0 ON CAPE AND UPPER
1533 ! LIMIT OF 0.0 ON CINS.
1534 ! ENFORCE LFC ABOVE LCL AND BELOW EL
1535 !
1536 !$omp parallel do private(i,j)
1537  DO j=jsta,jend
1538  DO i=ista,iend
1539  cape(i,j) = max(d00,cape(i,j))
1540  cins(i,j) = min(cins(i,j),d00)
1541 ! equillibrium height
1542  zeql(i,j) = zint(i,j,ieql(i,j))
1543  lfc(i,j) = min(lfc(i,j),zint(i,j,ieql(i,j)))
1544  lfc(i,j) = max(zint(i,j, lcl(i,j)),lfc(i,j))
1545  IF (cape20(i,j) < 75.) THEN
1546  thunder(i,j) = .false.
1547  ENDIF
1548  IF (thunder(i,j)) THEN
1549  thund(i,j) = 1.0
1550  ELSE
1551  thund(i,j) = 0.0
1552  ENDIF
1553  ENDDO
1554  ENDDO
1555 !------------COMPUTE DCAPE--------------------------------------
1556 !-----------------------------------------------------------------------
1557 !---------FIND TEMP OF PARCEL DESCENDED ALONG MOIST ADIABAT (TPAR)---------
1558 !-----------------------------------------------------------------------
1559  IF (itype == 1) THEN
1560 
1561  DO l=lm,1,-1
1562 !--------------SCALING PRESSURE & TT TABLE INDEX------------------------
1563  knuml = 0
1564  knumh = 0
1565  DO j=jsta,jend
1566  DO i=ista,iend
1567  klres(i,j) = 0
1568  khres(i,j) = 0
1569  psfck = pmid(i,j,nint(lmh(i,j)))
1570  pkl = pmid(i,j,l)
1571  IF(pkl >= psfck-dpbnd) THEN
1572  IF(pmid(i,j,l) < plq)THEN
1573  knuml = knuml + 1
1574  klres(i,j) = 1
1575  ELSE
1576  knumh = knumh + 1
1577  khres(i,j) = 1
1578  ENDIF
1579  ENDIF
1580  ENDDO
1581  ENDDO
1582 !***
1583 !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE<PLQ
1584 !**
1585  IF(knuml > 0) THEN
1586  CALL ttblex(tpar2(ista_2l,jsta_2l,l),ttbl,itb,jtb,klres &
1587  , pmid(ista_2l,jsta_2l,l),pl,qq,pp,rdp,the0,sthe &
1588  , rdthe,thesp2,iptb,ithtb)
1589  ENDIF
1590 !***
1591 !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ
1592 !**
1593  IF(knumh > 0) THEN
1594  CALL ttblex(tpar2(ista_2l,jsta_2l,l),ttblq,itbq,jtbq,khres &
1595  , pmid(ista_2l,jsta_2l,l),plq,qq,pp,rdpq &
1596  , the0q,stheq,rdtheq,thesp2,iptb,ithtb)
1597  ENDIF
1598  ENDDO ! end of do l=lm,1,-1 loop
1599 
1600  lbeg = 1
1601  lend = lm
1602 
1603  DO l=lbeg,lend
1604 !$omp parallel do private(i,j)
1605  DO j=jsta,jend
1606  DO i=ista,iend
1607  idx(i,j) = 0
1608  IF(l >= parcel2(i,j).AND.l < nint(lmh(i,j))) THEN
1609  idx(i,j) = 1
1610  ENDIF
1611  ENDDO
1612  ENDDO
1613 !
1614 !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv)
1615  DO j=jsta,jend
1616  DO i=ista,iend
1617  IF(idx(i,j) > 0) THEN
1618  presk = pmid(i,j,l)
1619  gdzkl = (zint(i,j,l)-zint(i,j,l+1)) * g
1620  esatp = min(fpvsnew(tpar2(i,j,l)),presk)
1621  qsatp = eps*esatp/(presk-esatp*oneps)
1622 ! TVP = TPAR2(I,J,L)*(1+0.608*QSATP)
1623  tvp = tvirtual(tpar2(i,j,l),qsatp)
1624  thetap = tvp*(h10e5/presk)**capa
1625 ! TV = T(I,J,L)*(1+0.608*Q(I,J,L))
1626  tv = tvirtual(t(i,j,l),q(i,j,l))
1627  thetaa = tv*(h10e5/presk)**capa
1628  !IF(THETAP < THETAA) THEN
1629  dcape(i,j) = dcape(i,j) + (log(thetap)-log(thetaa))*gdzkl
1630  !ENDIF
1631  ENDIF
1632  ENDDO
1633  ENDDO
1634  ENDDO
1635 
1636 !$omp parallel do private(i,j)
1637  DO j=jsta,jend
1638  DO i=ista,iend
1639  dcape(i,j) = min(d00,dcape(i,j))
1640  ENDDO
1641  ENDDO
1642 
1643  ENDIF !ITYPE=1 FOR DCAPE
1644 
1645 !
1646 ! Dendritic Growth Layer depth
1647 ! the layer with temperatures from -12 to -17 C in meters
1648 !
1649  l12=lm
1650  l17=lm
1651  DO l=lm,1,-1
1652 !$omp parallel do private(i,j)
1653  DO j=jsta,jend
1654  DO i=ista,iend
1655  IF(t(i,j,l) <= tfrz-12. .AND. l12(i,j)==lm) l12(i,j)=l
1656  IF(t(i,j,l) <= tfrz-17. .AND. l17(i,j)==lm) l17(i,j)=l
1657  ENDDO
1658  ENDDO
1659  ENDDO
1660 !$omp parallel do private(i,j)
1661  DO j=jsta,jend
1662  DO i=ista,iend
1663  IF(l12(i,j)/=lm .AND. l17(i,j)/=lm) THEN
1664  dgld(i,j)=zint(i,j,l17(i,j))-zint(i,j,l12(i,j))
1665  dgld(i,j)=max(dgld(i,j),0.)
1666  ENDIF
1667  ENDDO
1668  ENDDO
1669 !
1670 ! Enhanced Stretching Potential
1671 ! ESP = (0-3 km MLCAPE / 50 J kg-1) * ((0-3 km lapse rate - 7.0) / 1.0 C (km-1)
1672 ! https://www.spc.noaa.gov/exper/soundings/help/params4.html
1673 !
1674  l3km=lm
1675  DO l=lm,1,-1
1676 !$omp parallel do private(i,j)
1677  DO j=jsta,jend
1678  DO i=ista,iend
1679  IF(zint(i,j,l)-htsfc(i,j) <= 3000.) l3km(i,j)=l
1680  ENDDO
1681  ENDDO
1682  ENDDO
1683 !$omp parallel do private(i,j)
1684  DO j=jsta,jend
1685  DO i=ista,iend
1686  esp(i,j) = (cape(i,j) / 50.) * (t(i,j,lm) - t(i,j,l3km(i,j)) - 7.0)
1687  IF((t(i,j,lm) - t(i,j,l3km(i,j))) < 7.0) esp(i,j) = 0.
1688 ! IF(CAPE(I,J) < 250.) ESP(I,J) = 0.
1689  ENDDO
1690  ENDDO
1691 !
1692  DEALLOCATE(tpar)
1693  DEALLOCATE(tpar2)
1694 !
1695  END SUBROUTINE calcape2
1696 !
1697 !-------------------------------------------------------------------------------------
1698 !
1699 !
1700 !-------------------------------------------------------------------------------------
1701 !
1702  elemental function tvirtual(T,Q)
1703 !
1709 !
1710  IMPLICIT NONE
1711  REAL tvirtual
1712  REAL, INTENT(IN) :: t, q
1713 
1714  tvirtual = t*(1+0.608*q)
1715 
1716  end function tvirtual
1717 !
1718 !-------------------------------------------------------------------------------------
1719 !
1743 
1744  SUBROUTINE calvor(UWND,VWND,ABSV)
1745 
1746 !
1747  use vrbls2d, only: f
1748  use masks, only: gdlat, gdlon, dx, dy
1749  use params_mod, only: d00, dtr, small, erad
1750  use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, &
1751  jsta, jend, im, jm, jsta_m, jend_m, gdsdegr,&
1752  ista, iend, ista_m, iend_m, ista_2l, iend_2u, me, num_procs
1753  use gridspec_mod, only: gridtype, dyval
1754  use upp_math, only: dvdxdudy, ddvdx, ddudy, uuavg
1755 
1756  implicit none
1757 !
1758 ! DECLARE VARIABLES.
1759 !
1760  REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: uwnd, vwnd
1761  REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(inout) :: absv
1762  REAL, dimension(IM,2) :: glatpoles, coslpoles, upoles, avpoles
1763  REAL, dimension(IM,JSTA:JEND) :: cosltemp, avtemp
1764 !
1765  real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:)
1766  INTEGER, allocatable :: ihe(:),ihw(:), ie(:),iw(:)
1767 !
1768  integer, parameter :: npass2=2, npass3=3
1769  integer i,j,ip1,im1,ii,iir,iil,jj,jmt2,imb2, npass, nn, jtem
1770  real r2dx,r2dy,dvdx,dudy,uavg,tph1,tphi, tx1(im+2), tx2(im+2)
1771 !
1772 !***************************************************************************
1773 ! START CALVOR HERE.
1774 !
1775 ! LOOP TO COMPUTE ABSOLUTE VORTICITY FROM WINDS.
1776 !
1777  IF(modelname == 'RAPR') then
1778 !$omp parallel do private(i,j)
1779  DO j=jsta_2l,jend_2u
1780  DO i=ista_2l,iend_2u
1781  absv(i,j) = d00
1782  ENDDO
1783  ENDDO
1784  else
1785 !$omp parallel do private(i,j)
1786  DO j=jsta_2l,jend_2u
1787  DO i=ista_2l,iend_2u
1788  absv(i,j) = spval
1789  ENDDO
1790  ENDDO
1791  endif
1792 
1793 ! print*,'dyval in CALVOR= ',DYVAL
1794 
1795  CALL exch(uwnd)
1796  CALL exch(vwnd)
1797 !
1798  IF (modelname == 'GFS' .or. global) THEN
1799  CALL exch(gdlat(ista_2l,jsta_2l))
1800  CALL exch(gdlon(ista_2l,jsta_2l))
1801 
1802  allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), &
1803  & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u))
1804  allocate(iw(im),ie(im))
1805 
1806  imb2 = im/2
1807 !$omp parallel do private(i)
1808  do i=ista,iend
1809  ie(i) = i+1
1810  iw(i) = i-1
1811  enddo
1812 ! iw(1) = im
1813 ! ie(im) = 1
1814 
1815 ! if(1>=jsta .and. 1<=jend)then
1816 ! if(cos(gdlat(1,1)*dtr)<small)poleflag=.T.
1817 ! end if
1818 ! call mpi_bcast(poleflag,1,MPI_LOGICAL,0,mpi_comm_comp,iret)
1819 
1820 !$omp parallel do private(i,j,ip1,im1)
1821  DO j=jsta,jend
1822  do i=ista,iend
1823  ip1 = ie(i)
1824  im1 = iw(i)
1825  cosl(i,j) = cos(gdlat(i,j)*dtr)
1826  IF(cosl(i,j) >= small) then
1827  wrk1(i,j) = 1.0 / (erad*cosl(i,j))
1828  else
1829  wrk1(i,j) = 0.
1830  end if
1831  if(i == im .or. i == 1) then
1832  wrk2(i,j) = 1.0 / ((360.+gdlon(ip1,j)-gdlon(im1,j))*dtr) !1/dlam
1833  else
1834  wrk2(i,j) = 1.0 / ((gdlon(ip1,j)-gdlon(im1,j))*dtr) !1/dlam
1835  end if
1836  enddo
1837  enddo
1838 ! CALL EXCH(cosl(1,JSTA_2L))
1839  CALL exch(cosl)
1840 
1841  call fullpole( cosl(ista_2l:iend_2u,jsta_2l:jend_2u),coslpoles)
1842  call fullpole(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles)
1843 
1844  if(me==0 ) print*,'CALVOR ',me,glatpoles(ista,1),glatpoles(ista,2)
1845  if(me==num_procs-1) print*,'CALVOR ',me,glatpoles(ista,1),glatpoles(ista,2)
1846 
1847 !$omp parallel do private(i,j,ii)
1848  DO j=jsta,jend
1849  if (j == 1) then
1850  if(gdlat(ista,j) > 0.) then ! count from north to south
1851  do i=ista,iend
1852  ii = i + imb2
1853  if (ii > im) ii = ii - im
1854  ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi
1855  wrk3(i,j) = 1.0 / ((180.-gdlat(i,j+1)-glatpoles(ii,1))*dtr) !1/dphi
1856  enddo
1857  else ! count from south to north
1858  do i=ista,iend
1859  ii = i + imb2
1860  if (ii > im) ii = ii - im
1861  ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi
1862  wrk3(i,j) = 1.0 / ((180.+gdlat(i,j+1)+glatpoles(ii,1))*dtr) !1/dphi
1863 !
1864  enddo
1865  end if
1866  elseif (j == jm) then
1867  if(gdlat(ista,j) < 0.) then ! count from north to south
1868  do i=ista,iend
1869  ii = i + imb2
1870  if (ii > im) ii = ii - im
1871  ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR)
1872  wrk3(i,j) = 1.0 / ((180.+gdlat(i,j-1)+glatpoles(ii,2))*dtr)
1873  enddo
1874  else ! count from south to north
1875  do i=ista,iend
1876  ii = i + imb2
1877  if (ii > im) ii = ii - im
1878  ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR)
1879  wrk3(i,j) = 1.0 / ((180.-gdlat(i,j-1)-glatpoles(ii,2))*dtr)
1880  enddo
1881  end if
1882  else
1883  do i=ista,iend
1884  wrk3(i,j) = 1.0 / ((gdlat(i,j-1)-gdlat(i,j+1))*dtr) !1/dphi
1885  enddo
1886  endif
1887  enddo
1888 
1889  npass = 0
1890 
1891  jtem = jm / 18 + 1
1892 
1893  call fullpole(uwnd(ista_2l:iend_2u,jsta_2l:jend_2u),upoles)
1894 
1895 !$omp parallel do private(i,j,ip1,im1,ii,jj,tx1,tx2)
1896  DO j=jsta,jend
1897 ! npass = npass2
1898 ! if (j > jm-jtem+1 .or. j < jtem) npass = npass3
1899  IF(j == 1) then ! Near North or South pole
1900  if(gdlat(ista,j) > 0.) then ! count from north to south
1901  IF(cosl(ista,j) >= small) THEN !not a pole point
1902  DO i=ista,iend
1903  ip1 = ie(i)
1904  im1 = iw(i)
1905  ii = i + imb2
1906  if (ii > im) ii = ii - im
1907  if(vwnd(ip1,j)==spval .or. vwnd(im1,j)==spval .or. &
1908 ! UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle
1909  upoles(ii,1)==spval .or. uwnd(i,j+1)==spval) cycle
1910  absv(i,j) = ((vwnd(ip1,j)-vwnd(im1,j))*wrk2(i,j) &
1911 ! & + (UWND(II,J)*COSL(II,J) &
1912  & + (upoles(ii,1)*coslpoles(ii,1) &
1913  & + uwnd(i,j+1)*cosl(i,j+1))*wrk3(i,j)) * wrk1(i,j) &
1914  & + f(i,j)
1915  enddo
1916  ELSE !pole point, compute at j=2
1917  jj = 2
1918  DO i=ista,iend
1919  ip1 = ie(i)
1920  im1 = iw(i)
1921  if(vwnd(ip1,jj)==spval .or. vwnd(im1,jj)==spval .or. &
1922  uwnd(i,j)==spval .or. uwnd(i,jj+1)==spval) cycle
1923  absv(i,j) = ((vwnd(ip1,jj)-vwnd(im1,jj))*wrk2(i,jj) &
1924  & - (uwnd(i,j)*cosl(i,j) &
1925  - uwnd(i,jj+1)*cosl(i,jj+1))*wrk3(i,jj)) * wrk1(i,jj) &
1926  & + f(i,jj)
1927  enddo
1928  ENDIF
1929  else
1930  IF(cosl(ista,j) >= small) THEN !not a pole point
1931  DO i=ista,iend
1932  ip1 = ie(i)
1933  im1 = iw(i)
1934  ii = i + imb2
1935  if (ii > im) ii = ii - im
1936  if(vwnd(ip1,j)==spval .or. vwnd(im1,j)==spval .or. &
1937 ! UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle
1938  upoles(ii,1)==spval .or. uwnd(i,j+1)==spval) cycle
1939  absv(i,j) = ((vwnd(ip1,j)-vwnd(im1,j))*wrk2(i,j) &
1940 ! & - (UWND(II,J)*COSL(II,J) &
1941  & - (upoles(ii,1)*coslpoles(ii,1) &
1942  & + uwnd(i,j+1)*cosl(i,j+1))*wrk3(i,j)) * wrk1(i,j) &
1943  & + f(i,j)
1944  enddo
1945  ELSE !pole point, compute at j=2
1946  jj = 2
1947  DO i=ista,iend
1948  ip1 = ie(i)
1949  im1 = iw(i)
1950  if(vwnd(ip1,jj)==spval .or. vwnd(im1,jj)==spval .or. &
1951  uwnd(i,j)==spval .or. uwnd(i,jj+1)==spval) cycle
1952  absv(i,j) = ((vwnd(ip1,jj)-vwnd(im1,jj))*wrk2(i,jj) &
1953  & + (uwnd(i,j)*cosl(i,j) &
1954  - uwnd(i,jj+1)*cosl(i,jj+1))*wrk3(i,jj)) * wrk1(i,jj) &
1955  & + f(i,jj)
1956  enddo
1957  ENDIF
1958  endif
1959  ELSE IF(j == jm) THEN ! Near North or South Pole
1960  if(gdlat(ista,j) < 0.) then ! count from north to south
1961  IF(cosl(ista,j) >= small) THEN !not a pole point
1962  DO i=ista,iend
1963  ip1 = ie(i)
1964  im1 = iw(i)
1965  ii = i + imb2
1966  if (ii > im) ii = ii - im
1967  if(vwnd(ip1,j)==spval .or. vwnd(im1,j)==spval .or. &
1968 ! UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle
1969  uwnd(i,j-1)==spval .or. upoles(ii,2)==spval) cycle
1970  absv(i,j) = ((vwnd(ip1,j)-vwnd(im1,j))*wrk2(i,j) &
1971  & - (uwnd(i,j-1)*cosl(i,j-1) &
1972 ! & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) &
1973  & + upoles(ii,2)*coslpoles(ii,2))*wrk3(i,j)) * wrk1(i,j) &
1974  & + f(i,j)
1975  enddo
1976  ELSE !pole point,compute at jm-1
1977  jj = jm-1
1978  DO i=ista,iend
1979  ip1 = ie(i)
1980  im1 = iw(i)
1981  if(vwnd(ip1,jj)==spval .or. vwnd(im1,jj)==spval .or. &
1982  uwnd(i,jj-1)==spval .or. uwnd(i,j)==spval) cycle
1983  absv(i,j) = ((vwnd(ip1,jj)-vwnd(im1,jj))*wrk2(i,jj) &
1984  & - (uwnd(i,jj-1)*cosl(i,jj-1) &
1985  & - uwnd(i,j)*cosl(i,j))*wrk3(i,jj)) * wrk1(i,jj) &
1986  & + f(i,jj)
1987  enddo
1988  ENDIF
1989  else
1990  IF(cosl(ista,j) >= small) THEN !not a pole point
1991  DO i=ista,iend
1992  ip1 = ie(i)
1993  im1 = iw(i)
1994  ii = i + imb2
1995  if (ii > im) ii = ii - im
1996  if(vwnd(ip1,j)==spval .or. vwnd(im1,j)==spval .or. &
1997 ! UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle
1998  uwnd(i,j-1)==spval .or. upoles(ii,2)==spval) cycle
1999  absv(i,j) = ((vwnd(ip1,j)-vwnd(im1,j))*wrk2(i,j) &
2000  & + (uwnd(i,j-1)*cosl(i,j-1) &
2001 ! & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) &
2002  & + upoles(ii,2)*coslpoles(ii,2))*wrk3(i,j)) * wrk1(i,j) &
2003  & + f(i,j)
2004  enddo
2005  ELSE !pole point,compute at jm-1
2006  jj = jm-1
2007  DO i=ista,iend
2008  ip1 = ie(i)
2009  im1 = iw(i)
2010  if(vwnd(ip1,jj)==spval .or. vwnd(im1,jj)==spval .or. &
2011  uwnd(i,jj-1)==spval .or. uwnd(i,j)==spval) cycle
2012  absv(i,j) = ((vwnd(ip1,jj)-vwnd(im1,jj))*wrk2(i,jj) &
2013  & + (uwnd(i,jj-1)*cosl(i,jj-1) &
2014  & - uwnd(i,j)*cosl(i,j))*wrk3(i,jj)) * wrk1(i,jj) &
2015  & + f(i,jj)
2016  enddo
2017  ENDIF
2018  endif
2019  ELSE
2020  DO i=ista,iend
2021  ip1 = ie(i)
2022  im1 = iw(i)
2023  if(vwnd(ip1,j)==spval .or. vwnd(im1,j)==spval .or. &
2024  uwnd(i,j-1)==spval .or. uwnd(i,j+1)==spval) cycle
2025  absv(i,j) = ((vwnd(ip1,j)-vwnd(im1,j))*wrk2(i,j) &
2026  & - (uwnd(i,j-1)*cosl(i,j-1) &
2027  - uwnd(i,j+1)*cosl(i,j+1))*wrk3(i,j)) * wrk1(i,j) &
2028  + f(i,j)
2029  ENDDO
2030  END IF
2031 ! if(ABSV(I,J)>1.0)print*,'Debug CALVOR',i,j,VWND(ip1,J),VWND(im1,J), &
2032 ! wrk2(i,j),UWND(I,J-1),COSL(I,J-1),UWND(I,J+1),COSL(I,J+1),wrk3(i,j),cosl(i,j),F(I,J),ABSV(I,J)
2033  if (npass > 0) then
2034  do i=ista,iend
2035  tx1(i) = absv(i,j)
2036  enddo
2037  do nn=1,npass
2038  do i=ista,iend
2039  tx2(i+1) = tx1(i)
2040  enddo
2041  tx2(1) = tx2(im+1)
2042  tx2(im+2) = tx2(2)
2043  do i=2,im+1
2044  tx1(i-1) = 0.25 * (tx2(i-1) + tx2(i+1)) + 0.5*tx2(i)
2045  enddo
2046  enddo
2047  do i=ista,iend
2048  absv(i,j) = tx1(i)
2049  enddo
2050  endif
2051  END DO ! end of J loop
2052 
2053 ! deallocate (wrk1, wrk2, wrk3, cosl)
2054 ! GFS use lon avg as one scaler value for pole point
2055 
2056  ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,ABSV(1,jsta))
2057 
2058  call exch(absv(ista_2l:iend_2u,jsta_2l:jend_2u))
2059  call fullpole(absv(ista_2l:iend_2u,jsta_2l:jend_2u),avpoles)
2060 
2061  cosltemp=spval
2062  if(jsta== 1) cosltemp(1:im, 1)=coslpoles(1:im,1)
2063  if(jend==jm) cosltemp(1:im,jm)=coslpoles(1:im,2)
2064  avtemp=spval
2065  if(jsta== 1) avtemp(1:im, 1)=avpoles(1:im,1)
2066  if(jend==jm) avtemp(1:im,jm)=avpoles(1:im,2)
2067 
2068  call poleavg(im,jm,jsta,jend,small,cosltemp(1,jsta),spval,avtemp(1,jsta))
2069 
2070  if(jsta== 1) absv(ista:iend, 1)=avtemp(ista:iend, 1)
2071  if(jend==jm) absv(ista:iend,jm)=avtemp(ista:iend,jm)
2072 
2073  deallocate (wrk1, wrk2, wrk3, cosl, iw, ie)
2074 
2075  ELSE !(MODELNAME == 'GFS' .or. global)
2076 
2077  IF (gridtype == 'B')THEN
2078  CALL exch(vwnd)
2079  CALL exch(uwnd)
2080  ENDIF
2081 
2082  CALL dvdxdudy(uwnd,vwnd)
2083 
2084  IF(gridtype == 'A')THEN
2085 !$omp parallel do private(i,j,jmt2,tphi,r2dx,r2dy,dvdx,dudy,uavg)
2086  DO j=jsta_m,jend_m
2087  jmt2 = jm/2+1
2088  tphi = (j-jmt2)*(dyval/gdsdegr)*dtr
2089  DO i=ista_m,iend_m
2090  IF(ddvdx(i,j)<spval.AND.ddudy(i,j)<spval.AND. &
2091  uuavg(i,j)<spval.AND.uwnd(i,j)<spval.AND. &
2092  & uwnd(i,j+1)<spval.AND.uwnd(i,j-1)<spval) THEN
2093  dvdx = ddvdx(i,j)
2094  dudy = ddudy(i,j)
2095  uavg = uuavg(i,j)
2096 ! is there a (f+tan(phi)/erad)*u term?
2097  IF(modelname == 'RAPR' .OR. modelname == 'FV3R') then
2098  absv(i,j) = dvdx - dudy + f(i,j) ! for run RAP over north pole
2099  else
2100  absv(i,j) = dvdx - dudy + f(i,j) + uavg*tan(gdlat(i,j)*dtr)/erad ! not sure about this???
2101  endif
2102  END IF
2103  END DO
2104  END DO
2105 
2106  ELSE IF (gridtype == 'E')THEN
2107  allocate(ihw(jsta_2l:jend_2u), ihe(jsta_2l:jend_2u))
2108 !$omp parallel do private(j)
2109  DO j=jsta_2l,jend_2u
2110  ihw(j) = -mod(j,2)
2111  ihe(j) = ihw(j)+1
2112  ENDDO
2113 !$omp parallel do private(i,j,jmt2,tphi,r2dx,r2dy,dvdx,dudy,uavg)
2114  DO j=jsta_m,jend_m
2115  jmt2 = jm/2+1
2116  tphi = (j-jmt2)*(dyval/1000.)*dtr
2117  tphi = (j-jmt2)*(dyval/gdsdegr)*dtr
2118  DO i=ista_m,iend_m
2119  IF(vwnd(i+ihe(j),j) < spval.AND.vwnd(i+ihw(j),j) < spval .AND. &
2120  & uwnd(i,j+1) < spval .AND.uwnd(i,j-1) < spval) THEN
2121  dvdx = ddvdx(i,j)
2122  dudy = ddudy(i,j)
2123  uavg = uuavg(i,j)
2124 ! is there a (f+tan(phi)/erad)*u term?
2125  absv(i,j) = dvdx - dudy + f(i,j) + uavg*tan(tphi)/erad
2126  END IF
2127  END DO
2128  END DO
2129  deallocate(ihw, ihe)
2130  ELSE IF (gridtype == 'B')THEN
2131 ! CALL EXCH(VWND) !done before dvdxdudy() Jesse 20200520
2132  DO j=jsta_m,jend_m
2133  jmt2 = jm/2+1
2134  tphi = (j-jmt2)*(dyval/gdsdegr)*dtr
2135  DO i=ista_m,iend_m
2136  if(vwnd(i, j)==spval .or. vwnd(i, j-1)==spval .or. &
2137  vwnd(i-1,j)==spval .or. vwnd(i-1,j-1)==spval .or. &
2138  uwnd(i, j)==spval .or. uwnd(i-1,j)==spval .or. &
2139  uwnd(i,j-1)==spval .or. uwnd(i-1,j-1)==spval) cycle
2140  dvdx = ddvdx(i,j)
2141  dudy = ddudy(i,j)
2142  uavg = uuavg(i,j)
2143 ! is there a (f+tan(phi)/erad)*u term?
2144  absv(i,j) = dvdx - dudy + f(i,j) + uavg*tan(tphi)/erad
2145  END DO
2146  END DO
2147  END IF
2148  END IF
2149 !
2150 ! END OF ROUTINE.
2151 !
2152  RETURN
2153  END
2154 
2171 
2172 !-----------------------------------------------------------------------------
2174 !
2175  SUBROUTINE caldiv(UWND,VWND,DIV)
2176  use masks, only: gdlat, gdlon
2177  use params_mod, only: d00, dtr, small, erad
2178  use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, &
2179  jsta, jend, im, jm, jsta_m, jend_m, lm, &
2180  ista, iend, ista_m, iend_m, ista_2l, iend_2u
2181  use gridspec_mod, only: gridtype
2182 
2183  implicit none
2184 !
2185 ! DECLARE VARIABLES.
2186 !
2187  REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(in) :: uwnd,vwnd
2188  REAL, dimension(ista:iend,jsta:jend,lm), intent(inout) :: div
2189  REAL, dimension(IM,2) :: glatpoles, coslpoles, upoles, vpoles, divpoles
2190  REAL, dimension(IM,JSTA:JEND) :: cosltemp, divtemp
2191 !
2192  real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:)
2193  INTEGER, allocatable :: ihe(:),ihw(:), ie(:),iw(:)
2194 !
2195  real :: dnpole, dspole, tem
2196  integer i,j,ip1,im1,ii,iir,iil,jj,imb2, l
2197 !
2198 !***************************************************************************
2199 ! START CALDIV HERE.
2200 !
2201 ! LOOP TO COMPUTE DIVERGENCE FROM WINDS.
2202 !
2203  CALL exch(gdlat(ista_2l,jsta_2l))
2204  CALL exch(gdlon(ista_2l,jsta_2l))
2205 
2206  allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), &
2207  & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u))
2208  allocate(iw(im),ie(im))
2209 
2210  imb2 = im/2
2211 !$omp parallel do private(i)
2212  do i=ista,iend
2213  ie(i) = i+1
2214  iw(i) = i-1
2215  enddo
2216 ! iw(1) = im
2217 ! ie(im) = 1
2218 
2219 
2220 !$omp parallel do private(i,j,ip1,im1)
2221  DO j=jsta,jend
2222  do i=ista,iend
2223  ip1 = ie(i)
2224  im1 = iw(i)
2225  cosl(i,j) = cos(gdlat(i,j)*dtr)
2226  IF(cosl(i,j) >= small) then
2227  wrk1(i,j) = 1.0 / (erad*cosl(i,j))
2228  else
2229  wrk1(i,j) = 0.
2230  end if
2231  if(i == im .or. i == 1) then
2232  wrk2(i,j) = 1.0 / ((360.+gdlon(ip1,j)-gdlon(im1,j))*dtr) !1/dlam
2233  else
2234  wrk2(i,j) = 1.0 / ((gdlon(ip1,j)-gdlon(im1,j))*dtr) !1/dlam
2235  end if
2236  enddo
2237  ENDDO
2238 
2239  CALL exch(cosl)
2240  CALL fullpole(cosl,coslpoles)
2241  CALL fullpole(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles)
2242 
2243 !$omp parallel do private(i,j,ii)
2244  DO j=jsta,jend
2245  if (j == 1) then
2246  if(gdlat(ista,j) > 0.) then ! count from north to south
2247  do i=ista,iend
2248  ii = i + imb2
2249  if (ii > im) ii = ii - im
2250  ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi
2251  wrk3(i,j) = 1.0 / ((180.-gdlat(i,j+1)-glatpoles(ii,1))*dtr) !1/dphi
2252  enddo
2253  else ! count from south to north
2254  do i=ista,iend
2255  ii = i + imb2
2256  if (ii > im) ii = ii - im
2257  ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi
2258  wrk3(i,j) = 1.0 / ((180.+gdlat(i,j+1)+glatpoles(ii,1))*dtr) !1/dphi
2259  enddo
2260  end if
2261  elseif (j == jm) then
2262  if(gdlat(ista,j) < 0.) then ! count from north to south
2263  do i=ista,iend
2264  ii = i + imb2
2265  if (ii > im) ii = ii - im
2266  ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR)
2267  wrk3(i,j) = 1.0 / ((180.+gdlat(i,j-1)+glatpoles(ii,2))*dtr)
2268  enddo
2269  else ! count from south to north
2270  do i=ista,iend
2271  ii = i + imb2
2272  if (ii > im) ii = ii - im
2273  ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR)
2274  wrk3(i,j) = 1.0 / ((180.-gdlat(i,j-1)-glatpoles(ii,2))*dtr)
2275  enddo
2276  end if
2277  else
2278  do i=ista,iend
2279  wrk3(i,j) = 1.0 / ((gdlat(i,j-1)-gdlat(i,j+1))*dtr) !1/dphi
2280  enddo
2281  endif
2282  enddo
2283 
2284  do l=1,lm
2285 !$omp parallel do private(i,j)
2286  DO j=jsta,jend
2287  DO i=ista,iend
2288  div(i,j,l) = spval
2289  ENDDO
2290  ENDDO
2291 
2292  CALL exch(vwnd(ista_2l,jsta_2l,l))
2293  CALL exch(uwnd(ista_2l,jsta_2l,l))
2294 
2295  CALL fullpole(vwnd(ista_2l:iend_2u,jsta_2l:jend_2u,l),vpoles)
2296  CALL fullpole(uwnd(ista_2l:iend_2u,jsta_2l:jend_2u,l),upoles)
2297 
2298 !$omp parallel do private(i,j,ip1,im1,ii,jj)
2299  DO j=jsta,jend
2300  IF(j == 1) then ! Near North pole
2301  if(gdlat(ista,j) > 0.) then ! count from north to south
2302  IF(cosl(ista,j) >= small) THEN !not a pole point
2303  DO i=ista,iend
2304  ip1 = ie(i)
2305  im1 = iw(i)
2306  ii = i + imb2
2307  if (ii > im) ii = ii - im
2308  div(i,j,l) = ((uwnd(ip1,j,l)-uwnd(im1,j,l))*wrk2(i,j) &
2309  !& ! - (VWND(II,J,l)*COSL(II,J) &
2310  & - (vpoles(ii,1)*coslpoles(ii,1) &
2311  & + vwnd(i,j+1,l)*cosl(i,j+1))*wrk3(i,j)) * wrk1(i,j)
2312  enddo
2313 !--
2314  ELSE !North pole point, compute at j=2
2315  jj = 2
2316  do i=ista,iend
2317  ip1 = ie(i)
2318  im1 = iw(i)
2319  div(i,j,l) = ((uwnd(ip1,jj,l)-uwnd(im1,jj,l))*wrk2(i,jj) &
2320  & + (vwnd(i,j,l)*cosl(i,j) &
2321  - vwnd(i,jj+1,l)*cosl(i,jj+1))*wrk3(i,jj)) * wrk1(i,jj)
2322  enddo
2323 !--
2324  ENDIF
2325  else
2326  IF(cosl(ista,j) >= small) THEN !not a pole point
2327  DO i=ista,iend
2328  ip1 = ie(i)
2329  im1 = iw(i)
2330  ii = i + imb2
2331  if (ii > im) ii = ii - im
2332  div(i,j,l) = ((uwnd(ip1,j,l)-uwnd(im1,j,l))*wrk2(i,j) &
2333  !& ! + (VWND(II,J,l)*COSL(II,J) &
2334  & + (vpoles(ii,1)*coslpoles(ii,1) &
2335  & + vwnd(i,j+1,l)*cosl(i,j+1))*wrk3(i,j)) * wrk1(i,j)
2336  enddo
2337 !--
2338  ELSE !North pole point, compute at j=2
2339  jj = 2
2340  do i=ista,iend
2341  ip1 = ie(i)
2342  im1 = iw(i)
2343  div(i,j,l) = ((uwnd(ip1,jj,l)-uwnd(im1,jj,l))*wrk2(i,jj) &
2344  & - (vwnd(i,j,l)*cosl(i,j) &
2345  - vwnd(i,jj+1,l)*cosl(i,jj+1))*wrk3(i,jj)) * wrk1(i,jj)
2346  enddo
2347  ENDIF
2348  endif
2349  ELSE IF(j == jm) THEN ! Near South pole
2350  if(gdlat(ista,j) < 0.) then ! count from north to south
2351  IF(cosl(ista,j) >= small) THEN !not a pole point
2352  DO i=ista,iend
2353  ip1 = ie(i)
2354  im1 = iw(i)
2355  ii = i + imb2
2356  if (ii > im) ii = ii - im
2357  div(i,j,l) = ((uwnd(ip1,j,l)-uwnd(im1,j,l))*wrk2(i,j) &
2358  & + (vwnd(i,j-1,l)*cosl(i,j-1) &
2359  !& ! + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j)
2360  & + vpoles(ii,2)*coslpoles(ii,2))*wrk3(i,j)) * wrk1(i,j)
2361  enddo
2362 !--
2363  ELSE !South pole point,compute at jm-1
2364  jj = jm-1
2365  do i=ista,iend
2366  ip1 = ie(i)
2367  im1 = iw(i)
2368  div(i,j,l) = ((uwnd(ip1,jj,l)-uwnd(im1,jj,l))*wrk2(i,jj) &
2369  & + (vwnd(i,jj-1,l)*cosl(i,jj-1) &
2370  & - vwnd(i,j,l)*cosl(i,j))*wrk3(i,jj)) * wrk1(i,jj)
2371 
2372  enddo
2373  ENDIF
2374  else
2375  IF(cosl(ista,j) >= small) THEN !not a pole point
2376  DO i=ista,iend
2377  ip1 = ie(i)
2378  im1 = iw(i)
2379  ii = i + imb2
2380  if (ii > im) ii = ii - im
2381  div(i,j,l) = ((uwnd(ip1,j,l)-uwnd(im1,j,l))*wrk2(i,j) &
2382  & - (vwnd(i,j-1,l)*cosl(i,j-1) &
2383  !& ! + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j)
2384  & + vpoles(ii,2)*coslpoles(ii,2))*wrk3(i,j)) * wrk1(i,j)
2385  enddo
2386 !--
2387  ELSE !South pole point,compute at jm-1
2388  jj = jm-1
2389  do i=ista,iend
2390  ip1 = ie(i)
2391  im1 = iw(i)
2392  div(i,j,l) = ((uwnd(ip1,jj,l)-uwnd(im1,jj,l))*wrk2(i,jj) &
2393  & - (vwnd(i,jj-1,l)*cosl(i,jj-1) &
2394  & - vwnd(i,j,l)*cosl(i,j))*wrk3(i,jj)) * wrk1(i,jj)
2395 
2396  enddo
2397  ENDIF
2398  endif
2399  ELSE
2400  DO i=ista,iend
2401  ip1 = ie(i)
2402  im1 = iw(i)
2403  div(i,j,l) = ((uwnd(ip1,j,l)-uwnd(im1,j,l))*wrk2(i,j) &
2404  & + (vwnd(i,j-1,l)*cosl(i,j-1) &
2405  - vwnd(i,j+1,l)*cosl(i,j+1))*wrk3(i,j)) * wrk1(i,j)
2406 !sk06132016
2407  if(div(i,j,l)>1.0)print*,'Debug in CALDIV',i,j,uwnd(ip1,j,l),uwnd(im1,j,l), &
2408  & wrk2(i,j),vwnd(i,j-1,l),cosl(i,j-1),vwnd(i,j+1,l),cosl(i,j+1), &
2409  & wrk3(i,j),wrk1(i,j),div(i,j,l)
2410 !--
2411  ENDDO
2412  ENDIF
2413  ENDDO ! end of J loop
2414 
2415 ! GFS use lon avg as one scaler value for pole point
2416 ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,DIV(1,jsta,l))
2417 
2418  call exch(div(ista_2l:iend_2u,jsta_2l:jend_2u,l))
2419  call fullpole(div(ista_2l:iend_2u,jsta_2l:jend_2u,l),divpoles)
2420 
2421  cosltemp=spval
2422  IF(jsta== 1) cosltemp(1:im, 1)=coslpoles(1:im,1)
2423  IF(jend==jm) cosltemp(1:im,jm)=coslpoles(1:im,2)
2424  divtemp=spval
2425  IF(jsta== 1) divtemp(1:im, 1)=divpoles(1:im,1)
2426  IF(jend==jm) divtemp(1:im,jm)=divpoles(1:im,2)
2427 
2428  call poleavg(im,jm,jsta,jend,small,cosltemp(1:im,jsta:jend) &
2429  ,spval,divtemp(1:im,jsta:jend))
2430 
2431  IF(jsta== 1) div(ista:iend, 1,l)=divtemp(ista:iend, 1)
2432  IF(jend==jm) div(ista:iend,jm,l)=divtemp(ista:iend,jm)
2433 
2434 !sk06142016e
2435  if(div(ista,jsta,l)>1.0)print*,'Debug in CALDIV',jsta,div(ista,jsta,l)
2436 ! print*,'Debug in CALDIV',' jsta= ',jsta,DIV(1,jsta,l)
2437 
2438  enddo ! end of l looop
2439 !--
2440  deallocate (wrk1, wrk2, wrk3, cosl, iw, ie)
2441 
2442 
2443  END SUBROUTINE caldiv
2444 
2445 !------------------------------------------------------------------------
2462  SUBROUTINE calgradps(PS,PSX,PSY)
2463 
2464  use masks, only: gdlat, gdlon
2465  use params_mod, only: dtr, d00, small, erad
2466  use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, &
2467  jsta, jend, im, jm, jsta_m, jend_m, &
2468  ista, iend, ista_m, iend_m, ista_2l, iend_2u
2469 
2470  use gridspec_mod, only: gridtype
2471 
2472  implicit none
2473 !
2474 ! DECLARE VARIABLES.
2475 !
2476  REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: ps
2477  REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(inout) :: psx,psy
2478 !
2479  real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:)
2480  INTEGER, allocatable :: ihe(:),ihw(:), ie(:),iw(:)
2481 !
2482  integer i,j,ip1,im1,ii,iir,iil,jj,imb2
2483 !
2484 !***************************************************************************
2485 ! START CALGRADPS HERE.
2486 !
2487 ! LOOP TO COMPUTE ZONAL AND MERIDIONAL GRADIENTS OF PS OR LNPS
2488 !
2489 !sk06162016 DO J=JSTA_2L,JEND_2U
2490 !$omp parallel do private(i,j)
2491  DO j=jsta,jend
2492  DO i=ista,iend
2493  psx(i,j) = spval
2494  psy(i,j) = spval
2495 !sk PSX(I,J) = D00
2496 !sk PSY(I,J) = D00
2497  ENDDO
2498  ENDDO
2499 
2500  CALL exch(ps)
2501 
2502 ! IF (MODELNAME == 'GFS' .or. global) THEN
2503  CALL exch(gdlat(ista_2l,jsta_2l))
2504  CALL exch(gdlon(ista_2l,jsta_2l))
2505 
2506  allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), &
2507  & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u))
2508  allocate(iw(im),ie(im))
2509 
2510  imb2 = im/2
2511 !$omp parallel do private(i)
2512  do i=ista,iend
2513  ie(i) = i+1
2514  iw(i) = i-1
2515  enddo
2516 ! iw(1) = im
2517 ! ie(im) = 1
2518 
2519 
2520 !$omp parallel do private(i,j,ip1,im1)
2521  DO j=jsta,jend
2522  do i=ista,iend
2523  ip1 = ie(i)
2524  im1 = iw(i)
2525  cosl(i,j) = cos(gdlat(i,j)*dtr)
2526  if(cosl(i,j) >= small) then
2527  wrk1(i,j) = 1.0 / (erad*cosl(i,j))
2528  else
2529  wrk1(i,j) = 0.
2530  end if
2531  if(i == im .or. i == 1) then
2532  wrk2(i,j) = 1.0 / ((360.+gdlon(ip1,j)-gdlon(im1,j))*dtr) !1/dlam
2533  else
2534  wrk2(i,j) = 1.0 / ((gdlon(ip1,j)-gdlon(im1,j))*dtr) !1/dlam
2535  end if
2536  enddo
2537  ENDDO
2538 
2539  CALL exch(cosl)
2540 
2541 !$omp parallel do private(i,j,ii)
2542  DO j=jsta,jend
2543  if (j == 1) then
2544  if(gdlat(ista,j) > 0.) then ! count from north to south
2545  do i=ista,iend
2546  ii = i + imb2
2547  if (ii > im) ii = ii - im
2548  wrk3(i,j) = 1.0 / ((180.-gdlat(i,j+1)-gdlat(ii,j))*dtr) !1/dphi
2549  enddo
2550  else ! count from south to north
2551  do i=ista,iend
2552  ii = i + imb2
2553  if (ii > im) ii = ii - im
2554  wrk3(i,j) = 1.0 / ((180.+gdlat(i,j+1)+gdlat(ii,j))*dtr) !1/dphi
2555  enddo
2556  end if
2557  elseif (j == jm) then
2558  if(gdlat(ista,j) < 0.) then ! count from north to south
2559  do i=ista,iend
2560  ii = i + imb2
2561  if (ii > im) ii = ii - im
2562  wrk3(i,j) = 1.0 / ((180.+gdlat(i,j-1)+gdlat(ii,j))*dtr)
2563  enddo
2564  else ! count from south to north
2565  do i=ista,iend
2566  ii = i + imb2
2567  if (ii > im) ii = ii - im
2568  wrk3(i,j) = 1.0 / ((180.-gdlat(i,j-1)-gdlat(ii,j))*dtr)
2569  enddo
2570  end if
2571  else
2572  do i=ista,iend
2573  wrk3(i,j) = 1.0 / ((gdlat(i,j-1)-gdlat(i,j+1))*dtr) !1/dphi
2574  enddo
2575  endif
2576  ENDDO
2577 
2578 !$omp parallel do private(i,j,ip1,im1,ii,jj)
2579  DO j=jsta,jend
2580  IF(j == 1) then ! Near North pole
2581  if(gdlat(ista,j) > 0.) then ! count from north to south
2582  IF(cosl(ista,j) >= small) THEN !not a pole point
2583  DO i=ista,iend
2584  ip1 = ie(i)
2585  im1 = iw(i)
2586  ii = i + imb2
2587  if (ii > im) ii = ii - im
2588  psx(i,j) = (ps(ip1,j)-ps(im1,j))*wrk2(i,j)*wrk1(i,j)
2589  psy(i,j) = (ps(ii,j)-ps(i,j+1))*wrk3(i,j)/erad
2590  enddo
2591  ELSE !North pole point, compute at j=2
2592  jj = 2
2593  DO i=ista,iend
2594  ip1 = ie(i)
2595  im1 = iw(i)
2596  psx(i,j) = (ps(ip1,jj)-ps(im1,jj))*wrk2(i,jj)*wrk1(i,jj)
2597  psy(i,j) = (ps(i,j)-ps(i,jj+1))*wrk3(i,jj)/erad
2598  enddo
2599  ENDIF
2600  else
2601  IF(cosl(ista,j) >= small) THEN !not a pole point
2602  DO i=ista,iend
2603  ip1 = ie(i)
2604  im1 = iw(i)
2605  ii = i + imb2
2606  if (ii > im) ii = ii - im
2607  psx(i,j) = (ps(ip1,j)-ps(im1,j))*wrk2(i,j)*wrk1(i,j)
2608  psy(i,j) = - (ps(ii,j)-ps(i,j+1))*wrk3(i,j)/erad
2609  enddo
2610  ELSE !North pole point, compute at j=2
2611  jj = 2
2612  DO i=ista,iend
2613  ip1 = ie(i)
2614  im1 = iw(i)
2615  psx(i,j) = (ps(ip1,jj)-ps(im1,jj))*wrk2(i,jj)*wrk1(i,jj)
2616  psy(i,j) = - (ps(i,j)-ps(i,jj+1))*wrk3(i,jj)/erad
2617  enddo
2618  ENDIF
2619  endif
2620  ELSE IF(j == jm) THEN ! Near South pole
2621  if(gdlat(ista,j) < 0.) then ! count from north to south
2622  IF(cosl(ista,j) >= small) THEN !not a pole point
2623  DO i=ista,iend
2624  ip1 = ie(i)
2625  im1 = iw(i)
2626  ii = i + imb2
2627  if (ii > im) ii = ii - im
2628  psx(i,j) = (ps(ip1,j)-ps(im1,j))*wrk2(i,j)*wrk1(i,j)
2629  psy(i,j) = (ps(i,j-1)-ps(ii,j))*wrk3(i,j)/erad
2630  enddo
2631  ELSE !South pole point,compute at jm-1
2632  jj = jm-1
2633  DO i=ista,iend
2634  ip1 = ie(i)
2635  im1 = iw(i)
2636  psx(i,j) = (ps(ip1,jj)-ps(im1,jj))*wrk2(i,jj)*wrk1(i,jj)
2637  psy(i,j) = (ps(i,jj-1)-ps(i,j))*wrk3(i,jj)/erad
2638  enddo
2639  ENDIF
2640  else
2641  IF(cosl(ista,j) >= small) THEN !not a pole point
2642  DO i=ista,iend
2643  ip1 = ie(i)
2644  im1 = iw(i)
2645  ii = i + imb2
2646  if (ii > im) ii = ii - im
2647  psx(i,j) = (ps(ip1,j)-ps(im1,j))*wrk2(i,j)*wrk1(i,j)
2648  psy(i,j) = - (ps(i,j-1)-ps(ii,j))*wrk3(i,j)/erad
2649  enddo
2650  ELSE !South pole point,compute at jm-1
2651  jj = jm-1
2652  DO i=ista,iend
2653  ip1 = ie(i)
2654  im1 = iw(i)
2655  psx(i,j) = (ps(ip1,jj)-ps(im1,jj))*wrk2(i,jj)*wrk1(i,jj)
2656  psy(i,j) = - (ps(i,jj-1)-ps(i,j))*wrk3(i,jj)/erad
2657  enddo
2658  ENDIF
2659  endif
2660  ELSE
2661  DO i=ista,iend
2662  ip1 = ie(i)
2663  im1 = iw(i)
2664  psx(i,j) = (ps(ip1,j)-ps(im1,j))*wrk2(i,j)*wrk1(i,j)
2665  psy(i,j) = (ps(i,j-1)-ps(i,j+1))*wrk3(i,j)/erad
2666 !sk06142016A
2667  if(psx(i,j)>100.0)print*,'Debug in CALGRADPS: PSX',i,j,ps(ip1,j),ps(im1,j), &
2668 ! print*,'Debug in CALGRADPS',i,j,PS(ip1,J),PS(im1,J), &
2669  & wrk2(i,j),wrk1(i,j),psx(i,j)
2670  if(psy(i,j)>100.0)print*,'Debug in CALGRADPS: PSY',i,j,ps(i,j-1),ps(i,j+1), &
2671 ! print*,'Debug in CALGRADPS',i,j,PS(i,J-1),PS(i,J+1), &
2672  & wrk3(i,j),erad,psy(i,j)
2673 !--
2674  ENDDO
2675  END IF
2676 !
2677  ENDDO ! end of J loop
2678 
2679  deallocate (wrk1, wrk2, wrk3, cosl, iw, ie)
2680 
2681 ! END IF
2682 
2683  END SUBROUTINE calgradps
2684 
2704 
2705  SUBROUTINE calslr_roebber(tprs,rhprs,slr)
2706 
2707  use masks, only: lmh
2708  use vrbls2d, only: slp, avgprec_cont, u10, v10, pshltr, tshltr, qshltr
2709  use vrbls3d, only: t, q, pmid, pint
2710  use ctlblk_mod, only: ista, iend, jsta, jend, &
2711  ista_2l, iend_2u, jsta_2l, jend_2u, &
2712  im, jm, lm, lsm, spl, modelname, spval, me, idat
2713  use params_mod, only: capa, h1, h100
2714  use grib2_module, only: read_grib2_sngle
2715 
2716  implicit none
2717 
2718  real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lsm),intent(in) :: tprs
2719  real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lsm),intent(in) :: rhprs
2720  real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: slr !slr=snod/weasd=1000./sndens
2721 
2722 ! local variables
2723 
2724  character*256 :: climofile
2725  logical file_exists
2726  integer :: ntot, height
2727  real,dimension(im,jm) :: climo
2728  real,dimension(ista:iend,jsta:jend) :: climosub
2729 
2730  real,dimension(ista:iend,jsta:jend) :: p1d,t1d,q1d,rh1d
2731  real,dimension(ista:iend,jsta:jend) :: t2m,rh2m
2732 
2733  type all_grids
2734  real :: grid
2735  real :: sigma
2736  end type all_grids
2737 
2738  real prob1, prob2, prob3
2739  real,dimension(0:14), parameter :: sig = &
2740  (/0.0, 1.0, 0.975, 0.95, 0.925, 0.9, 0.875, 0.85, &
2741  0.8, 0.75, 0.7, 0.65, 0.6, 0.5, 0.4/)
2742  real,dimension(12), parameter :: mf = &
2743  (/1.0, 0.67, 0.33, 0.0, -0.33, -0.67, -1.00, -0.67, -0.33, 0.0, 0.33, 0.67/)
2744  integer, dimension(0:37), parameter :: levels = &
2745  (/2, 1000, 975, 950, 925, 900, 875, 850, 825, 800, 775, 750, 725, 700, &
2746  675, 650, 625, 600, 575, 550, 525, 500, 475, 450, 425, 400, &
2747  375, 350, 325, 300, 275, 250, 225, 200, 175, 150, 125, 100/)
2748 
2749  real,dimension(0:14) :: tm, rhm
2750 
2751  real,dimension(0:30), parameter :: co1 = &
2752  (/0.0, -.2926, .0070, -.0099, .0358, .0356, .0353, .0333, .0291, &
2753  .0235, .0169, .0060, -.0009, -.0052, -.0079, -.0093,&
2754  -.0116, -.0137, .0030, .0033, -.0005, -.0024, -.0023,&
2755  -.0021, -.0007, .0013, .0023, .0024, .0012, .0002, -.0010/)
2756 
2757  real,dimension(0:30), parameter :: co2 = &
2758  (/0.0, -9.7961, .0099, -.0222, -.0036, -.0012, .0010, .0018, .0018,&
2759  .0011, -.0001, -.0016, -.0026, -.0021, -.0015, -.0010,&
2760  -.0008, -.0017, .0238, .0213, .0253, .0232, .0183, .0127,&
2761  .0041, -.0063, -.0088, -.0062, -.0029, .0002, .0019/)
2762 
2763  real,dimension(0:30), parameter :: co3 = &
2764  (/0.0, 5.0037, -0.0097, -.0130, -.0170, -.0158, -.0141, -.0097,&
2765  -.0034, .0032, .0104, .0200, .0248, .0273, .0280, .0276,&
2766  .0285, .0308, -.0036, -.0042, -.0013, .0011, .0014, .0023,&
2767  .0011, -.0004, -.0022, -.0030, -.0033, -.0031, -.0019/)
2768 
2769  real,dimension(0:30), parameter :: co4 = &
2770  (/0.0, -5.0141, .0172, -.0267, .0015, .0026, .0033, .0015, -.0007,&
2771  -.0030, -.0063, -.0079, -.0074, -.0055, -.0035, -.0015,&
2772  -.0038, -.0093, .0052, .0059, .0019, -.0022, -.0077, -.0102,&
2773  -.0109, -.0077, .0014, .0160, .0217, .0219, .0190/)
2774 
2775  real,dimension(0:30), parameter :: co5 = &
2776  (/0.0, -5.2807, -.0240, .0228, .0067, .0019, -.0010, -.0003, .0012,&
2777  .0027, .0056, .0067, .0067, .0034, .0005, -.0026, -.0039,&
2778  -.0033, -.0225, -.0152, -.0157, -.0094, .0049, .0138,&
2779  .0269, .0388, .0334, .0147, .0018, -.0066, -.0112/)
2780 
2781  real,dimension(0:30), parameter :: co6 = &
2782  (/0.0, -2.2663, .0983, .3666, .0100, .0062, .0020, -.0008, -.0036,&
2783  -.0052, -.0074, -.0086, -.0072, -.0057, -.0040, -.0011,&
2784  .0006, .0014, .0012, -.0005, -.0019, .0003, -.0007, -.0008,&
2785  .0022, .0005, -.0016, -.0052, -.0024, .0008, .0037/)
2786 
2787  type(all_grids), dimension(ista:iend,jsta:jend,0:lsm) :: tmpk_grids, rh_grids
2788  integer, dimension(ista:iend,jsta:jend,0:lsm) :: tmpk_levels, rh_levels
2789 
2790  real,dimension(ista:iend,jsta:jend) :: hprob,mprob,lprob
2791  real,dimension(ista:iend,jsta:jend) :: slrgrid, slrgrid2
2792  real,dimension(ista:iend,jsta:jend) :: psfc,pres,qpf,swnd,prp
2793 
2794  character*20 nswfilename
2795  real :: psurf,p,sgw,sg1,sg2,dtds,rhds
2796  real :: f1,f2,f3,f4,f5,f6
2797  real :: p1,p2,p3
2798  real :: hprob_tot
2799  real :: mprob_tot
2800  real :: lprob_tot
2801 
2802  integer :: i,j,k,ks,l,ll,imo,iday
2803 !
2804 !***************************************************************************
2805 !
2806 ! day and month of the year
2807 
2808  imo = idat(1)
2809  iday= idat(2)
2810 
2811 ! climatology
2812 ! currently not used, snoden climatology files saved in fix directory
2813 !
2814 ! climoFile='climo_snoden'
2815 ! ntot=im*jm
2816 ! CLIMO = spval
2817 ! CLIMOSUB = spval
2818 ! INQUIRE(FILE=climoFile, EXIST=file_exists)
2819 ! if(file_exists) then
2820 ! print*,trim(climoFile),' FOUND'
2821 ! call read_grib2_sngle(climoFile,ntot,height,CLIMO)
2822 ! do j=jsta,jend
2823 ! do i=ista,iend
2824 ! if(CLIMO(i,j).gt.0 .and. CLIMO(i,j).lt.1000) CLIMOSUB(i,j)=1000./CLIMO(i,j)
2825 ! endif
2826 ! end do
2827 ! end do
2828 ! else
2829 ! print*,trim(climoFile),' NOT FOUND'
2830 ! endif !if(file_exist)
2831 
2832 ! surface variables
2833 
2834 !$omp parallel do private(i,j)
2835  DO j=jsta,jend
2836  DO i=ista,iend
2837  psfc(i,j)=pint(i,j,nint(lmh(i,j))+1)
2838  pres(i,j)=slp(i,j)
2839  qpf(i,j)=avgprec_cont(i,j)*3600.*3.
2840  swnd(i,j)=spval
2841  IF(u10(i,j)/=spval .AND. v10(i,j)/=spval) &
2842  swnd(i,j)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
2843  END DO
2844  END DO
2845 
2846 ! T2M and RH2M
2847 
2848 !$omp parallel do private(i,j)
2849  DO j=jsta,jend
2850  DO i=ista,iend
2851  IF(modelname=='RAPR')THEN
2852  p1d(i,j) = pmid(i,j,nint(lmh(i,j)))
2853  t1d(i,j) = t(i,j,nint(lmh(i,j)))
2854  ELSE
2855  p1d(i,j) = pint(i,j,lm+1)*exp(-0.068283/tshltr(i,j))
2856  t1d(i,j) = tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa
2857  ENDIF
2858  q1d(i,j) = qshltr(i,j)
2859  t2m(i,j) = t1d(i,j)
2860  ENDDO
2861  ENDDO
2862 
2863  CALL calrh(p1d,t1d,q1d,rh1d)
2864 
2865 !$omp parallel do private(i,j)
2866  DO j=jsta,jend
2867  DO i=ista,iend
2868  if(qshltr(i,j) /= spval)then
2869  rh2m(i,j) = min(h100,max(h1,rh1d(i,j)*100.))
2870  else
2871  rh2m(i,j) = spval
2872  endif
2873  ENDDO
2874  ENDDO
2875 
2876 !$omp parallel do private(i,j)
2877  do j=jsta,jend
2878  do i=ista,iend
2879  tmpk_grids(i,j,0)%grid=t2m(i,j)-273.15
2880  tmpk_levels(i,j,0)=pres(i,j)
2881  rh_grids(i,j,0)%grid=rh2m(i,j)
2882  rh_levels(i,j,0)=pres(i,j)
2883  end do
2884  end do
2885 
2886 ! T and RH all pressure levels
2887 
2888  DO l=1,lsm
2889  ll=lsm-l+1
2890 !!!$omp parallel do private(i,j,ll)
2891  do j=jsta,jend
2892  do i=ista,iend
2893  tmpk_grids(i,j,ll)%grid=tprs(i,j,l)-273.15
2894  tmpk_levels(i,j,ll)=spl(l)
2895  rh_grids(i,j,ll)%grid=rhprs(i,j,l)
2896  rh_levels(i,j,ll)=spl(l)
2897  end do
2898  end do
2899  END DO
2900 
2901 ! convert to sigma
2902 
2903  tmpk_grids(:,:,0)%sigma = 1.0
2904  rh_grids(:,:,0)%sigma = 1.0
2905 
2906  DO l=1,lsm
2907  ll=lsm-l+1
2908 !!!$omp parallel do private(i,j,ll)
2909  do j=jsta,jend
2910  do i=ista,iend
2911  if(pres(i,j) == spval) then
2912  tmpk_grids(i,j,ll)%sigma=spval
2913  rh_grids(i,j,ll)%sigma=spval
2914  else
2915  tmpk_grids(i,j,ll)%sigma=tmpk_levels(i,j,ll)/pres(i,j)
2916  rh_grids(i,j,ll)%sigma=rh_levels(i,j,ll)/pres(i,j)
2917  prp(i,j)=pres(i,j)/psfc(i,j)
2918  prp(i,j)=prp(i,j)*100000./psfc(i,j)
2919  endif
2920  end do
2921  end do
2922  END DO
2923 
2924 ! main slr i/j loop starts
2925 
2926  do j=jsta,jend
2927  do i=ista,iend
2928  tm=spval
2929  rhm=spval
2930  slr(i,j)=spval
2931  slrgrid(i,j)=spval
2932  slrgrid2(i,j)=spval
2933  hprob(i,j)=spval
2934  mprob(i,j)=spval
2935  lprob(i,j)=spval
2936 
2937  if(pres(i,j)/=spval .and. qpf(i,j)/=spval .and. swnd(i,j)/=spval) then
2938 
2939 ! Interpolate T and RH to the 14 sigma levels
2940 
2941  do ks=1,14
2942  psurf=pres(i,j)
2943  sgw=sig(ks)
2944  p=prp(i,j)
2945  do ll=0,lsm-1
2946  if(ll==0) then
2947  sg1 = psurf/psurf
2948  else
2949  sg1 = tmpk_levels(i,j,ll)/psurf
2950  endif
2951  sg2 = tmpk_levels(i,j,ll+1)/psurf
2952 
2953  if(sg1 == sgw) then
2954  tm(ks) = tmpk_grids(i,j,ll)%grid
2955  rhm(ks)= rh_grids(i,j,ll)%grid
2956  elseif (sg2 == sgw) then
2957  tm(ks) = tmpk_grids(i,j,ll+1)%grid
2958  rhm(ks)= rh_grids(i,j,ll+1)%grid
2959  elseif ((sgw < sg1) .and. (sgw > sg2)) then
2960  dtds = (tmpk_grids(i,j,ll+1)%grid - tmpk_grids(i,j,ll)%grid)/(sg2-sg1)
2961  tm(ks) = ((sgw - sg1) * dtds) + tmpk_grids(i,j,ll)%grid
2962  rhds = (rh_grids(i,j,ll+1)%grid - rh_grids(i,j,ll)%grid)/(sg2-sg1)
2963  rhm(ks)= ((sgw - sg1) * rhds) + rh_grids(i,j,ll)%grid
2964  endif
2965  end do
2966  end do !loop ks
2967 
2968 ! Have surface wind, QPF, and temp/RH on the 14 sigma levels.
2969 ! Convert these data to the factors using regression equations
2970 
2971  f1 = co1(1)+co1(2)*qpf(i,j)+co1(3)*swnd(i,j)+co1(4)*tm(1)+co1(5)*tm(2)+co1(6)*tm(3)+ &
2972  co1(7)*tm(4)+co1(8)*tm(5)+co1(9)*tm(6)+co1(10)*tm(7)+co1(11)*tm(8)+ &
2973  co1(12)*tm(9)+co1(13)*tm(10)+co1(14)*tm(11)+co1(15)*tm(12)+co1(16)*tm(13)+ &
2974  co1(17)*tm(14)+co1(18)*rhm(1)+co1(19)*rhm(2)+co1(20)*rhm(3)+co1(21)*rhm(4)+ &
2975  co1(22)*rhm(5)+co1(23)*rhm(6)+co1(24)*rhm(7)+co1(25)*rhm(8)+co1(26)*rhm(9)+ &
2976  co1(27)*rhm(10)+co1(28)*rhm(11)+co1(29)*rhm(12)+co1(30)*rhm(13)
2977 
2978  f2 = co2(1)+co2(2)*qpf(i,j)+co2(3)*swnd(i,j)+co2(4)*tm(1)+co2(5)*tm(2)+co2(6)*tm(3)+ &
2979  co2(7)*tm(4)+co2(8)*tm(5)+co2(9)*tm(6)+co2(10)*tm(7)+co2(11)*tm(8)+ &
2980  co2(12)*tm(9)+co2(13)*tm(10)+co2(14)*tm(11)+co2(15)*tm(12)+co2(16)*tm(13)+ &
2981  co2(17)*tm(14)+co2(18)*rhm(1)+co2(19)*rhm(2)+co2(20)*rhm(3)+co2(21)*rhm(4)+ &
2982  co2(22)*rhm(5)+co2(23)*rhm(6)+co2(24)*rhm(7)+co2(25)*rhm(8)+co2(26)*rhm(9)+ &
2983  co2(27)*rhm(10)+co2(28)*rhm(11)+co2(29)*rhm(12)+co2(30)*rhm(13)
2984 
2985  f3 = co3(1)+co3(2)*qpf(i,j)+co3(3)*swnd(i,j)+co3(4)*tm(1)+co3(5)*tm(2)+co3(6)*tm(3)+ &
2986  co3(7)*tm(4)+co3(8)*tm(5)+co3(9)*tm(6)+co3(10)*tm(7)+co3(11)*tm(8)+ &
2987  co3(12)*tm(9)+co3(13)*tm(10)+co3(14)*tm(11)+co3(15)*tm(12)+co3(16)*tm(13)+ &
2988  co3(17)*tm(14)+co3(18)*rhm(1)+co3(19)*rhm(2)+co3(20)*rhm(3)+co3(21)*rhm(4)+ &
2989  co3(22)*rhm(5)+co3(23)*rhm(6)+co3(24)*rhm(7)+co3(25)*rhm(8)+co3(26)*rhm(9)+ &
2990  co3(27)*rhm(10)+co3(28)*rhm(11)+co3(29)*rhm(12)+co3(30)*rhm(13)
2991 
2992  f4 = co4(1)+co4(2)*qpf(i,j)+co4(3)*swnd(i,j)+co4(4)*tm(1)+co4(5)*tm(2)+co4(6)*tm(3)+ &
2993  co4(7)*tm(4)+co4(8)*tm(5)+co4(9)*tm(6)+co4(10)*tm(7)+co4(11)*tm(8)+ &
2994  co4(12)*tm(9)+co4(13)*tm(10)+co4(14)*tm(11)+co4(15)*tm(12)+co4(16)*tm(13)+ &
2995  co4(17)*tm(14)+co4(18)*rhm(1)+co4(19)*rhm(2)+co4(20)*rhm(3)+co4(21)*rhm(4)+ &
2996  co4(22)*rhm(5)+co4(23)*rhm(6)+co4(24)*rhm(7)+co4(25)*rhm(8)+co4(26)*rhm(9)+ &
2997  co4(27)*rhm(10)+co4(28)*rhm(11)+co4(29)*rhm(12)+co4(30)*rhm(13)
2998 
2999  f5 = co5(1)+co5(2)*qpf(i,j)+co5(3)*swnd(i,j)+co5(4)*tm(1)+co5(5)*tm(2)+co5(6)*tm(3)+ &
3000  co5(7)*tm(4)+co5(8)*tm(5)+co5(9)*tm(6)+co5(10)*tm(7)+co5(11)*tm(8)+ &
3001  co5(12)*tm(9)+co5(13)*tm(10)+co5(14)*tm(11)+co5(15)*tm(12)+co5(16)*tm(13)+ &
3002  co5(17)*tm(14)+co5(18)*rhm(1)+co5(19)*rhm(2)+co5(20)*rhm(3)+co5(21)*rhm(4)+ &
3003  co5(22)*rhm(5)+co5(23)*rhm(6)+co5(24)*rhm(7)+co5(25)*rhm(8)+co5(26)*rhm(9)+ &
3004  co5(27)*rhm(10)+co5(28)*rhm(11)+co5(29)*rhm(12)+co5(30)*rhm(13)
3005 
3006  f6 = co6(1)+co6(2)*qpf(i,j)+co6(3)*swnd(i,j)+co6(4)*tm(1)+co6(5)*tm(2)+co6(6)*tm(3)+ &
3007  co6(7)*tm(4)+co6(8)*tm(5)+co6(9)*tm(6)+co6(10)*tm(7)+co6(11)*tm(8)+ &
3008  co6(12)*tm(9)+co6(13)*tm(10)+co6(14)*tm(11)+co6(15)*tm(12)+co6(16)*tm(13)+ &
3009  co6(17)*tm(14)+co6(18)*rhm(1)+co6(19)*rhm(2)+co6(20)*rhm(3)+co6(21)*rhm(4)+ &
3010  co6(22)*rhm(5)+co6(23)*rhm(6)+co6(24)*rhm(7)+co6(25)*rhm(8)+co6(26)*rhm(9)+ &
3011  co6(27)*rhm(10)+co6(28)*rhm(11)+co6(29)*rhm(12)+co6(30)*rhm(13)
3012 
3013  hprob_tot = 0.
3014  mprob_tot = 0.
3015  lprob_tot = 0.
3016  do k=1,10
3017  if(k==1) then
3018  nswfilename='Breadboard1.nsw'
3019  call breadboard1_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3020  elseif(k==2) then
3021  nswfilename='Breadboard2.nsw'
3022  call breadboard1_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3023  elseif(k==3) then
3024  nswfilename='Breadboard3.nsw'
3025  call breadboard1_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3026  elseif(k==4) then
3027  nswfilename='Breadboard4.nsw'
3028  call breadboard1_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3029  elseif(k==5) then
3030  nswfilename='Breadboard5.nsw'
3031  call breadboard1_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3032  elseif(k==6) then
3033  nswfilename='Breadboard6.nsw'
3034  call breadboard6_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3035  elseif(k==7) then
3036  nswfilename='Breadboard7.nsw'
3037  call breadboard6_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3038  elseif(k==8) then
3039  nswfilename='Breadboard8.nsw'
3040  call breadboard6_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3041  elseif(k==9) then
3042  nswfilename='Breadboard9.nsw'
3043  call breadboard6_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3044  elseif(k==10) then
3045  nswfilename='Breadboard10.nsw'
3046  call breadboard6_main(nswfilename,mf(imo),f1,f2,f3,f4,f5,f6,p1,p2,p3)
3047  endif
3048  hprob_tot = hprob_tot+p1
3049  mprob_tot = mprob_tot+p2
3050  lprob_tot = lprob_tot+p3
3051  enddo
3052  hprob(i,j) = hprob_tot/10.
3053  mprob(i,j) = mprob_tot/10.
3054  lprob(i,j) = lprob_tot/10.
3055 
3056  if(hprob(i,j) > mprob(i,j) .and. hprob(i,j) > lprob(i,j)) then
3057  slrgrid(i,j) = 8.0
3058  elseif(mprob(i,j) >= hprob(i,j) .and. mprob(i,j) >= lprob(i,j)) then
3059  slrgrid(i,j) = 13.0
3060  elseif(lprob(i,j) > hprob(i,j) .and. lprob(i,j) > mprob(i,j)) then
3061  if(lprob(i,j) < .67) then
3062  slrgrid(i,j) = 18.0
3063  else
3064  slrgrid(i,j) = 27.0
3065  endif
3066  endif
3067 
3068 ! Weighted SLR
3069 
3070  if(lprob(i,j) < .67) then
3071  slrgrid2(i,j) = hprob(i,j)*8.0+mprob(i,j)*13.0+lprob(i,j)*18.0
3072  slrgrid2(i,j) = slrgrid2(i,j)*p/(hprob(i,j)+mprob(i,j)+lprob(i,j))
3073  else
3074  slrgrid2(i,j) = hprob(i,j)*8.0+mprob(i,j)*13.0+lprob(i,j)*27.0
3075  slrgrid2(i,j) = slrgrid2(i,j)*p/(hprob(i,j)+mprob(i,j)+lprob(i,j))
3076  endif
3077 
3078 ! slr(i,j) = climosub(i,j)
3079 ! slr(i,j) = slrgrid(i,j)
3080  slr(i,j) = slrgrid2(i,j)
3081  slr(i,j) = max(1.,min(25.,slr(i,j)))
3082 
3083  endif !if(pres(i,j), qpf(i,j), swnd(i,j) /= spval)
3084  enddo
3085  enddo
3086 
3087 ! main slr i/j loop ends
3088 
3089  END SUBROUTINE calslr_roebber
3090 !
3091 !-------------------------------------------------------------------------------------
3092 !
3093  SUBROUTINE breadboard1_main(nswFileName,mf,f1,f2,f3,f4,f5,f6,p1,p2,p3)
3094 
3095  implicit none
3096 
3097  character*20 nswfilename
3098  real mf, f1, f2, f3, f4, f5, f6
3099  real p1, p2, p3
3100 
3101  real f(7)
3102 
3103  real inputfile(2,7)
3104  real inputaxon(7)
3105  real hidden1axon(40)
3106  real outputaxon(3)
3107  real hidden1synapse(7,40)
3108  real outputsynapse(40,3)
3109  real activeoutputprobe(2,3)
3110 
3111  real fgrid1(40), fgrid2(3), fgridsum
3112 
3113  integer i,j
3114 !
3115  f(1) = mf
3116  f(2) = f1
3117  f(3) = f2
3118  f(4) = f3
3119  f(5) = f4
3120  f(6) = f5
3121  f(7) = f6
3122 
3123 ! Read nsw file and load weights
3124 
3125  inputfile(1,:)=1.
3126  inputfile(2,:)=0.
3127  inputaxon=0.
3128  hidden1axon=0.
3129  outputaxon=0.
3130  hidden1synapse=1.
3131  outputsynapse=1.
3132  activeoutputprobe(1,:)=1.
3133  activeoutputprobe(2,:)=0.
3134 
3135  if(trim(nswfilename)=='Breadboard1.nsw') then
3136  call breadboard1(inputfile,hidden1axon,hidden1synapse,outputsynapse)
3137  elseif(trim(nswfilename)=='Breadboard2.nsw') then
3138  call breadboard2(inputfile,hidden1axon,hidden1synapse,outputsynapse)
3139  elseif(trim(nswfilename)=='Breadboard3.nsw') then
3140  call breadboard3(inputfile,hidden1axon,hidden1synapse,outputsynapse)
3141  elseif(trim(nswfilename)=='Breadboard4.nsw') then
3142  call breadboard4(inputfile,hidden1axon,hidden1synapse,outputsynapse)
3143  elseif(trim(nswfilename)=='Breadboard5.nsw') then
3144  call breadboard5(inputfile,hidden1axon,hidden1synapse,outputsynapse)
3145  endif
3146 
3147  if(activeoutputprobe(1,1)==1.) then
3148  do j=1,3
3149  activeoutputprobe(1,j)=8.999999761581421e-001
3150  activeoutputprobe(2,j)=5.000000074505806e-002
3151  enddo
3152  endif
3153 
3154 ! Run Network
3155 
3156  do j=1,7
3157  inputaxon(j) = inputfile(1,j) * f(j) + inputfile(2,j)
3158  enddo
3159 
3160  fgrid1=0.
3161 !$omp parallel do private(i,j)
3162  do j=1,40
3163  do i=1,7
3164  fgrid1(j) = fgrid1(j) + hidden1synapse(i,j) * inputaxon(i)
3165  enddo
3166  fgrid1(j) = fgrid1(j) + hidden1axon(j)
3167  fgrid1(j) = (exp(fgrid1(j))-exp(-fgrid1(j)))/(exp(fgrid1(j))+exp(-fgrid1(j)))
3168  enddo
3169 
3170  fgrid2=0.
3171  fgridsum=0.
3172  do j=1,3
3173  do i=1,40
3174  fgrid2(j) = fgrid2(j) + outputsynapse(i,j) * fgrid1(i)
3175  enddo
3176  fgrid2(j) = fgrid2(j) + outputaxon(j)
3177  fgrid2(j) = exp(fgrid2(j))
3178  fgridsum = fgridsum + fgrid2(j)
3179  enddo
3180  do j=1,3
3181  fgrid2(j) = fgrid2(j) / fgridsum
3182 ! fgrid2(j) = activeOutputProbe(1,j) * fgrid2(j) + activeOutputProbe(2,j)
3183  enddo
3184 
3185  p1 = fgrid2(1)
3186  p2 = fgrid2(2)
3187  p3 = fgrid2(3)
3188 
3189  END SUBROUTINE breadboard1_main
3190 !
3191 !-------------------------------------------------------------------------------------
3192 !
3193  SUBROUTINE breadboard6_main(nswFileName,mf,f1,f2,f3,f4,f5,f6,p1,p2,p3)
3194 
3195  implicit none
3196 
3197  character*20 nswfilename
3198  real mf, f1, f2, f3, f4, f5, f6
3199  real p1, p2, p3
3200 
3201  real f(7)
3202 
3203  real inputfile(2,7)
3204  real inputaxon(7)
3205  real hidden1axon(7)
3206  real hidden2axon(4)
3207  real outputaxon(3)
3208  real hidden1synapse(7,7)
3209  real hidden2synapse(7,4)
3210  real outputsynapse(4,3)
3211  real activeoutputprobe(2,3)
3212 
3213  real fgrid1(7), fgrid2(4), fgrid3(3), fgridsum
3214 
3215  integer i,j
3216 !
3217  f(1) = mf
3218  f(2) = f1
3219  f(3) = f2
3220  f(4) = f3
3221  f(5) = f4
3222  f(6) = f5
3223  f(7) = f6
3224 !
3225  inputfile(1,:)=1.
3226  inputfile(2,:)=0.
3227  inputaxon=0.
3228  hidden1axon=0.
3229  hidden2axon=0.
3230  outputaxon=0.
3231  hidden1synapse=1.
3232  hidden2synapse=1.
3233  outputsynapse=1.
3234  activeoutputprobe(1,:)=1.
3235  activeoutputprobe(2,:)=0.
3236 
3237  if(trim(nswfilename)=='Breadboard6.nsw') then
3238  call breadboard6(inputfile,hidden1axon,hidden2axon,&
3239  hidden1synapse,hidden2synapse,outputsynapse)
3240  elseif(trim(nswfilename)=='Breadboard7.nsw') then
3241  call breadboard7(inputfile,hidden1axon,hidden2axon,&
3242  hidden1synapse,hidden2synapse,outputsynapse)
3243  elseif(trim(nswfilename)=='Breadboard8.nsw') then
3244  call breadboard8(inputfile,hidden1axon,hidden2axon,&
3245  hidden1synapse,hidden2synapse,outputsynapse)
3246  elseif(trim(nswfilename)=='Breadboard9.nsw') then
3247  call breadboard9(inputfile,hidden1axon,hidden2axon,&
3248  hidden1synapse,hidden2synapse,outputsynapse)
3249  elseif(trim(nswfilename)=='Breadboard10.nsw') then
3250  call breadboard10(inputfile,hidden1axon,hidden2axon,&
3251  hidden1synapse,hidden2synapse,outputsynapse)
3252  endif
3253 
3254  if(activeoutputprobe(1,1)==1.) then
3255  do j=1,3
3256  activeoutputprobe(1,j)=8.999999761581421e-001
3257  activeoutputprobe(2,j)=5.000000074505806e-002
3258  enddo
3259  endif
3260 
3261 ! Run Network
3262 
3263  do j=1,7
3264  inputaxon(j) = inputfile(1,j) * f(j) + inputfile(2,j)
3265  enddo
3266 
3267  fgrid1=0.
3268 !$omp parallel do private(i,j)
3269  do j=1,7
3270  do i=1,7
3271  fgrid1(j) = fgrid1(j) + hidden1synapse(i,j) * inputaxon(i)
3272  enddo
3273  fgrid1(j) = fgrid1(j) + hidden1axon(j)
3274  fgrid1(j) = (exp(fgrid1(j))-exp(-fgrid1(j)))/(exp(fgrid1(j))+exp(-fgrid1(j)))
3275  enddo
3276 
3277  fgrid2=0.
3278 !$omp parallel do private(i,j)
3279  do j=1,4
3280  do i=1,7
3281  fgrid2(j) = fgrid2(j) + hidden2synapse(i,j) * fgrid1(i)
3282  enddo
3283  fgrid2(j) = fgrid2(j) + hidden2axon(j)
3284  fgrid2(j) = (exp(fgrid2(j))-exp(-fgrid2(j)))/(exp(fgrid2(j))+exp(-fgrid2(j)))
3285  enddo
3286 
3287  fgrid3=0.
3288  fgridsum=0.
3289  do j=1,3
3290  do i=1,4
3291  fgrid3(j) = fgrid3(j) + outputsynapse(i,j) * fgrid2(i)
3292  enddo
3293  fgrid3(j) = fgrid3(j) + outputaxon(j)
3294  fgrid3(j) = exp(fgrid3(j))
3295  fgridsum = fgridsum + fgrid3(j)
3296  enddo
3297  do j=1,3
3298  fgrid3(j) = fgrid3(j) / fgridsum
3299 ! fgrid3(j) = activeOutputProbe(1,j) * fgrid3(j) + activeOutputProbe(2,j)
3300  enddo
3301 
3302  p1 = fgrid3(1)
3303  p2 = fgrid3(2)
3304  p3 = fgrid3(3)
3305 
3306  END SUBROUTINE breadboard6_main
3307 !
3308 !------------------------------------------------------------------------------
3309 !
3310  SUBROUTINE breadboard1(inputFile,hidden1Axon,hidden1Synapse,outputSynapse)
3311 
3312  implicit none
3313 
3314  real inputfile(2,7)
3315  real hidden1axon(40)
3316  real hidden1synapse(7,40)
3317  real outputsynapse(40,3)
3318 
3319  inputfile = reshape((/ &
3320  1.077844262123108e+00, -1.778443008661270e-01,&
3321  2.295625507831573e-01, 6.163756549358368e-02,&
3322  2.081887423992157e-01, 6.210270524024963e-01,&
3323  3.646677434444427e-01, 1.214343756437302e-01,&
3324  2.430133521556854e-01, 3.004860281944275e-01,&
3325  1.935067623853683e-01, 4.185551702976227e-01,&
3326  1.962280571460724e-01, -4.804643988609314e-01 &
3327  /), shape(inputfile))
3328 
3329  hidden1axon = &
3330  (/-1.150484442710876e+00, -1.461968779563904e+00, 1.349107265472412e+00, 6.686212420463562e-01,&
3331  -8.486616015434265e-01, -1.908162593841553e+00, -1.514992356300354e+00, -1.632351636886597e+00,&
3332  -1.794843912124634e+00, 1.354879975318909e+00, 1.389558911323547e+00, 1.464104652404785e+00,&
3333  1.896052122116089e+00, 1.401677846908569e+00, 1.436681509017944e+00, -1.590880393981934e+00,&
3334  -1.070504426956177e+00, 2.047163248062134e+00, 1.564107656478882e+00, 1.298712372779846e+00,&
3335  -1.316817998886108e+00, -1.253177642822266e+00, -1.392926216125488e+00, 7.356406450271606e-01,&
3336  1.594561100006104e+00, -1.532955884933472e+00, -1.021214842796326e+00, 1.341110348701477e+00,&
3337  6.124811172485352e-01, 1.415654063224792e+00, -8.509962558746338e-01, 1.753035664558411e+00,&
3338  6.275475621223450e-01, 1.482843875885010e+00, 1.326028347015381e+00, 1.641556143760681e+00,&
3339  1.339018464088440e+00, -1.374068379402161e+00, -1.220067739486694e+00, 1.714797854423523e+00/)
3340 
3341  hidden1synapse = reshape((/ &
3342  -4.612099826335907e-01, -3.177818655967712e-01, -2.800635099411011e-01, -6.984808295965195e-02,&
3343  6.583837419748306e-02, -5.769817233085632e-01, 3.955098092556000e-01, -1.624705344438553e-01,&
3344  -2.889076173305511e-01, -9.411631226539612e-01, -5.058886408805847e-01, -3.110982775688171e-01,&
3345  -3.723000884056091e-01, 8.419776558876038e-01, 2.598794996738434e-01, -1.364605724811554e-01,&
3346  9.416468143463135e-01, -4.025689139962196e-02, 4.176554381847382e-01, 1.196979433298111e-01,&
3347  -3.846398293972015e-01, -1.414917409420013e-01, -2.344214916229248e+00, -3.556166291236877e-01,&
3348  -7.762963771820068e-01, -1.243659138679504e+00, 4.907984733581543e-01, -1.891903519630432e+00,&
3349  -5.802390575408936e-01, -5.546363592147827e-01, -4.520095884799957e-01, -2.473797500133514e-01,&
3350  -7.757837772369385e-01, -5.350160598754883e-01, 1.817676275968552e-01, -1.932217180728912e-01,&
3351  5.944451093673706e-01, -6.568105518817902e-02, -1.562235504388809e-01, 4.926294833421707e-02,&
3352  -6.931540369987488e-01, 7.082754969596863e-01, -3.878217563033104e-02, 5.063381195068359e-01,&
3353  -7.642447352409363e-01, -2.539043128490448e-01, -4.328470230102539e-01, -4.773662984371185e-01,&
3354  6.699458956718445e-01, -1.670347154140472e-01, 6.986252665519714e-01, -6.806275844573975e-01,&
3355  1.059119179844856e-01, 5.320579931139946e-02, -4.806780517101288e-01, 7.601988911628723e-01,&
3356  -1.864496916532516e-01, -3.076690435409546e-01, -6.505665779113770e-01, 7.355872541666031e-02,&
3357  -4.033335149288177e-01, -2.168276757001877e-01, 5.354191064834595e-01, 2.991014420986176e-01,&
3358  4.275756180286407e-01, 6.465418934822083e-01, -1.401910781860352e-01, 5.381527543067932e-01,&
3359  9.247279167175293e-01, -3.687029778957367e-01, 6.354923844337463e-01, -1.423558890819550e-01,&
3360  9.430686831474304e-01, 1.187003701925278e-01, 5.426434278488159e-01, 7.573884129524231e-01,&
3361  3.361994773149490e-02, 3.300542756915092e-02, -4.439333379268646e-01, 5.953744649887085e-01,&
3362  3.412617444992065e-01, 1.421828866004944e-01, 5.224847793579102e-01, -8.267756700515747e-01,&
3363  5.009499788284302e-01, 2.736742198467255e-01, 8.603093624114990e-01, 9.373022615909576e-02,&
3364  1.714528501033783e-01, 9.114132076501846e-02, -1.638108491897583e-01, 5.879403948783875e-01,&
3365  5.585592240095139e-03, 8.149939179420471e-01, -1.340572237968445e-01, 3.880683779716492e-01,&
3366  3.857498764991760e-01, -8.105239868164062e-01, 5.239543914794922e-01, 7.420576363801956e-02,&
3367  7.694411277770996e-01, -3.954831138253212e-02, 5.615213513374329e-01, 4.560695886611938e-01,&
3368  -5.006425976753235e-01, -4.725854694843292e-01, 5.887325108051300e-02, -3.199687898159027e-01,&
3369  -5.229111015796661e-02, -6.034490466117859e-01, -8.414428234100342e-01, 1.826022863388062e-01,&
3370  -6.954011321067810e-01, -5.277091860771179e-01, -9.834931492805481e-01, -2.964940369129181e-01,&
3371  1.752081327140331e-02, -2.412298470735550e-01, 5.861807465553284e-01, 3.650662600994110e-01,&
3372  -1.846716850996017e-01, 3.277707397937775e-01, 1.213769540190697e-01, 1.398152709007263e-01,&
3373  1.624975651502609e-01, -7.172397375106812e-01, -4.065496101975441e-02, -1.131931394338608e-01,&
3374  7.050336003303528e-01, 3.453079611063004e-02, 5.642467141151428e-01, 7.171959280967712e-01,&
3375  -3.295499980449677e-01, 5.192958116531372e-01, 7.558688521385193e-01, 6.164067387580872e-01,&
3376  -1.597565859556198e-01, 1.512383669614792e-01, 5.231227278709412e-01, -2.199545800685883e-01,&
3377  -3.987313508987427e-01, -9.710572957992554e-01, -4.689137935638428e-01, -4.037811756134033e-01,&
3378  -4.528387784957886e-01, -4.784810543060303e-01, 1.759306043386459e-01, 7.449938654899597e-01,&
3379  1.120681285858154e+00, -5.609570741653442e-01, 1.393345594406128e+00, 1.374282408505678e-02,&
3380  -2.458193153142929e-01, 1.237058401107788e+00, -4.854794219136238e-02, -6.664386391639709e-01,&
3381  -8.786886334419250e-01, -3.208510577678680e-01, -4.315690398216248e-01, -5.186472535133362e-01,&
3382  -2.117208093404770e-01, 8.998587727546692e-02, 7.763032317161560e-01, 1.078992128372192e+00,&
3383  3.667660653591156e-01, 5.805531740188599e-01, 1.517073512077332e-01, 9.344519972801208e-01,&
3384  3.396262824535370e-01, 2.450248003005981e-01, 9.134629368782043e-01, 7.127542048692703e-02,&
3385  -1.287281513214111e-01, 3.953699469566345e-01, -4.097535610198975e-01, -5.983641743659973e-01,&
3386  4.500437378883362e-01, -8.147508651018143e-02, -7.916551083326340e-02, -1.505649089813232e-01,&
3387  -1.703914403915405e-01, 1.294612526893616e+00, -4.859757721424103e-01, -1.034098416566849e-01,&
3388  -6.859915256500244e-01, 4.521823674440384e-02, 3.100419938564301e-01, -9.373775720596313e-01,&
3389  5.841451883316040e-01, 7.020491957664490e-01, -1.681403964757919e-01, 6.397892832756042e-01,&
3390  1.168430075049400e-01, 4.124156236648560e-01, 5.404921174049377e-01, -3.311195969581604e-01,&
3391  -3.494578003883362e-01, 1.379718184471130e+00, 2.731607258319855e-01, 5.512273311614990e-01,&
3392  2.997024357318878e-01, 3.475511670112610e-01, 6.777516603469849e-01, 1.471205204725266e-01,&
3393  1.011002138257027e-01, 8.974244594573975e-01, 8.688372373580933e-02, 4.767233729362488e-01,&
3394  9.785303473472595e-01, -2.200428694486618e-01, -6.173372268676758e-01, -8.801369071006775e-01,&
3395  -1.111719012260437e+00, -3.223371803760529e-01, -6.491173505783081e-01, -3.894545435905457e-01,&
3396  -2.843862473964691e-01, 7.331426739692688e-01, -3.287445753812790e-02, -5.741032306104898e-03,&
3397  6.212961673736572e-01, 3.749484941363335e-02, 6.244438700377941e-03, -6.228777766227722e-01,&
3398  -4.667133837938309e-02, 2.016694307327271e+00, 2.834755480289459e-01, 6.229624748229980e-01,&
3399  6.552317738533020e-01, -9.771268069744110e-02, 7.506207823753357e-01, 6.942567825317383e-01,&
3400  -1.662521809339523e-01, 3.003259599208832e-01, -2.531996071338654e-01, 2.399661689996719e-01,&
3401  5.109554529190063e-01, -7.031706571578979e-01, 2.836774885654449e-01, 4.888223409652710e-01,&
3402  1.384589523077011e-01, -3.524579405784607e-01, -2.050135582685471e-01, 1.160808563232422e+00,&
3403  -4.008938968181610e-01, 1.656456440687180e-01, -5.116114616394043e-01, 8.800522685050964e-01,&
3404  6.836380064487457e-02, -5.902936309576035e-02, 5.672354102134705e-01, -7.219299674034119e-01,&
3405  3.463289514183998e-02, -1.044675827026367e+00, -8.341925591230392e-02, -3.036961853504181e-01,&
3406  -5.605638027191162e-01, 5.722484588623047e-01, -1.604338049888611e+00, -5.696258544921875e-01,&
3407  -2.531512081623077e-01, -4.675458073616028e-01, -6.486019492149353e-01, -2.437075823545456e-01,&
3408  -2.898264527320862e-01, 3.836293518543243e-01, 4.061043560504913e-01, 3.909072279930115e-01,&
3409  -8.113911151885986e-01, 1.260317683219910e+00, -3.924282491207123e-01, 3.586370870471001e-02,&
3410  7.703443765640259e-01, 6.714462637901306e-01, -4.909946396946907e-02, 3.536651730537415e-01,&
3411  1.900762617588043e-01, 3.638494014739990e-01, 2.248179465532303e-01, -6.255846619606018e-01 &
3412  /), shape(hidden1synapse))
3413 
3414  outputsynapse = reshape((/ &
3415  -4.825605154037476e-01, -1.119017243385315e+00, 5.116804838180542e-01, -6.694142222404480e-01,&
3416  -5.718530416488647e-01, -7.233589291572571e-01, -8.200560212135315e-01, -6.121573448181152e-01,&
3417  -1.034205436706543e+00, 1.015549778938293e+00, 1.183975338935852e+00, 5.342597365379333e-01,&
3418  1.186208128929138e+00, 7.657266259193420e-01, 9.990772604942322e-01, -1.051267385482788e+00,&
3419  -7.288008332252502e-01, 9.447612762451172e-01, 6.943449974060059e-01, 5.248318314552307e-01,&
3420  -1.042970657348633e+00, -4.857340827584267e-04, -8.969252705574036e-01, 5.206210613250732e-01,&
3421  7.825390100479126e-01, -3.175100982189178e-01, -7.697273492813110e-01, 3.042222857475281e-01,&
3422  7.400255203247070e-01, 1.082547545433044e+00, -1.058874249458313e+00, 3.296852707862854e-01,&
3423  9.955985546112061e-01, 7.361931800842285e-01, 8.618848919868469e-01, 7.109408378601074e-01,&
3424  1.148022636771202e-01, -6.803723573684692e-01, -4.462003335356712e-02, 7.384030222892761e-01,&
3425  -2.215545326471329e-01, -8.702403903007507e-01, 8.234908580780029e-01, 6.819239258766174e-01,&
3426  -4.687527120113373e-01, -6.959788203239441e-01, -6.105158329010010e-01, -7.225347757339478e-01,&
3427  -7.860832810401917e-01, 5.608791112899780e-01, 9.937217235565186e-01, 6.797130703926086e-01,&
3428  8.231667280197144e-01, 1.115462303161621e+00, 5.290299654006958e-01, -4.602016210556030e-01,&
3429  -5.394889116287231e-01, 1.053055644035339e+00, 9.533493518829346e-01, 8.694807887077332e-01,&
3430  -4.802323281764984e-01, -1.070514082908630e+00, -8.236010670661926e-01, 7.932062149047852e-01,&
3431  1.111655592918396e+00, -1.025945305824280e+00, -2.268178462982178e-01, 6.432797908782959e-01,&
3432  2.442117929458618e-01, 7.986634969711304e-01, -3.561095297336578e-01, 1.058865070343018e+00,&
3433  6.459046602249146e-01, 4.042869210243225e-01, 2.976681292057037e-02, 1.033244490623474e+00,&
3434  9.110773205757141e-01, -6.528528332710266e-01, -8.971995115280151e-01, 1.046785235404968e+00,&
3435  -5.487565994262695e-01, -1.033755183219910e+00, 5.164890289306641e-01, 1.108534336090088e+00,&
3436  -2.507440149784088e-01, -1.150385260581970e+00, -1.040475010871887e+00, -1.114320755004883e+00,&
3437  -9.695596694946289e-01, 9.147439599037170e-01, 3.035557866096497e-01, 1.044997453689575e+00,&
3438  1.059857130050659e+00, 7.304399013519287e-01, 1.102171182632446e+00, -9.304327964782715e-01,&
3439  -5.997116565704346e-01, 1.120478868484497e+00, 6.444569826126099e-01, 2.137384265661240e-01,&
3440  -4.117920994758606e-01, -1.000458717346191e+00, -2.041520774364471e-01, -1.859422773122787e-01,&
3441  3.711319267749786e-01, -9.141649603843689e-01, -7.499164938926697e-01, 9.900025129318237e-01,&
3442  -2.189985066652298e-01, 8.942219614982605e-01, -3.195305764675140e-01, 6.445295810699463e-01,&
3443  -2.110123336315155e-01, 9.763143658638000e-01, 8.833498954772949e-01, 1.071311354637146e+00,&
3444  1.134591102600098e+00, -4.175429344177246e-01, -6.000540852546692e-01, 7.281569838523865e-01 &
3445  /), shape(outputsynapse))
3446 
3447  END SUBROUTINE breadboard1
3448 !
3449 !------------------------------------------------------------------------------
3450 !
3451  SUBROUTINE breadboard2(inputFile,hidden1Axon,hidden1Synapse,outputSynapse)
3452 
3453  implicit none
3454 
3455  real inputfile(2,7)
3456  real hidden1axon(40)
3457  real hidden1synapse(7,40)
3458  real outputsynapse(40,3)
3459 
3460  inputfile = reshape((/ &
3461  1.077844262123108e+00, -1.778443008661270e-01,&
3462  2.188449800014496e-01, 1.674167998135090e-02,&
3463  1.868382692337036e-01, 6.490761637687683e-01,&
3464  3.361344337463379e-01, 4.151264205574989e-02,&
3465  2.621995508670807e-01, 2.531536519527435e-01,&
3466  1.944894641637802e-01, 3.221717774868011e-01,&
3467  3.179650008678436e-01, -2.033386379480362e-01 &
3468  /), shape(inputfile))
3469 
3470  hidden1axon = &
3471  (/-9.235364943742752e-02, -5.511198639869690e-01, 1.012191653251648e+00, -1.148184835910797e-01,&
3472  -8.399781584739685e-01, -4.726789295673370e-01, 7.570160627365112e-01, -3.985013365745544e-01,&
3473  1.164000511169434e+00, 2.212587594985962e-01, 9.570528268814087e-01, -1.504407286643982e+00,&
3474  -1.262813359498978e-01, 9.741528630256653e-01, 2.278975844383240e-01, -3.282702267169952e-01,&
3475  1.716251969337463e-01, 4.979004263877869e-01, 6.414948105812073e-01, -2.775986790657043e-01,&
3476  -6.721665859222412e-01, 7.226511836051941e-01, -1.020949006080627e+00, -9.638186097145081e-01,&
3477  4.050622135400772e-02, -8.287806510925293e-01, -2.900803685188293e-01, 1.004199028015137e+00,&
3478  -1.221053838729858e+00, -5.891714692115784e-01, -6.459002494812012e-01, 8.228222727775574e-01,&
3479  1.921370178461075e-01, 1.575044542551041e-01, -9.904603362083435e-01, 1.186665743589401e-01,&
3480  1.871918141841888e-01, -6.121324300765991e-01, 1.056765243411064e-01, -5.654883384704590e-01/)
3481 
3482  hidden1synapse = reshape((/ &
3483  -5.215738341212273e-02, 6.958795785903931e-01, -3.700282871723175e-01, 4.440588057041168e-01,&
3484  -9.248711913824081e-02, 9.709199517965317e-02, 1.255098581314087e-01, -1.359838247299194e-01,&
3485  3.981630802154541e-01, -4.047442674636841e-01, -5.247595906257629e-01, -5.138890147209167e-01,&
3486  2.293408364057541e-01, 5.139534473419189e-01, 2.035804986953735e-01, 3.003124892711639e-01,&
3487  -2.340262830257416e-01, 3.037432730197906e-01, 4.666079878807068e-01, 3.753643631935120e-01,&
3488  -5.292671918869019e-02, 3.674933612346649e-01, 3.854512274265289e-01, 1.749511361122131e-01,&
3489  1.320011764764786e-01, 2.418431788682938e-01, 1.245125234127045e-01, -2.677426636219025e-01,&
3490  3.884479776024818e-02, -1.385747641324997e-01, -3.117613494396210e-01, 3.016934990882874e-01,&
3491  -2.856997251510620e-01, -4.838032424449921e-01, 4.488031566143036e-01, -3.862534165382385e-01,&
3492  2.520084977149963e-01, -6.066129356622696e-02, -2.037643343210220e-01, -9.749407321214676e-02,&
3493  1.909288167953491e-01, -2.689029574394226e-01, 8.022837042808533e-01, 4.543448388576508e-01,&
3494  1.268999278545380e-01, 2.794430553913116e-01, 4.331161379814148e-01, -1.717756092548370e-01,&
3495  -5.167780518531799e-01, 6.074145808815956e-02, 2.141399085521698e-01, -3.536535203456879e-01,&
3496  -2.548796236515045e-01, -4.349331259727478e-01, 3.771509276703000e-03, 1.351494044065475e-01,&
3497  8.080910146236420e-02, -2.638687789440155e-01, 1.792310923337936e-01, -5.317723155021667e-01,&
3498  6.300682574510574e-02, 1.391339004039764e-01, -6.581404209136963e-01, 1.574699729681015e-01,&
3499  -5.979638695716858e-01, -6.864693760871887e-01, -6.892689466476440e-01, -1.189238503575325e-01,&
3500  -1.904999166727066e-01, -4.838389158248901e-01, 4.585682973265648e-02, 3.201213181018829e-01,&
3501  5.204908251762390e-01, -3.531241044402122e-02, 4.392628967761993e-01, 4.307939708232880e-01,&
3502  -4.227218031883240e-02, 1.247199028730392e-01, 1.489800363779068e-01, -3.146159052848816e-01,&
3503  2.637389600276947e-01, -8.966535329818726e-02, 2.010040730237961e-01, 3.161593675613403e-01,&
3504  -8.221558481454849e-02, -4.601925909519196e-01, -3.832246661186218e-01, 2.877672016620636e-01,&
3505  -1.351716276258230e-02, -5.320604424923658e-03, -3.493662178516388e-02, -1.777663826942444e-01,&
3506  -1.865815520286560e-01, 6.387206912040710e-01, -4.405377805233002e-01, 4.452396631240845e-01,&
3507  -1.245370283722878e-01, -2.323225736618042e-01, 1.697962284088135e-01, 1.118463352322578e-01,&
3508  -2.475701570510864e-01, -3.791887685656548e-02, 5.509998202323914e-01, 1.247667223215103e-01,&
3509  3.189268708229065e-01, -3.584641516208649e-01, 8.915060758590698e-01, 9.720049053430557e-02,&
3510  -1.117252558469772e-01, 3.543806076049805e-01, -2.351483702659607e-01, 5.283502340316772e-01,&
3511  1.746209561824799e-01, 1.741478294134140e-01, 2.738423347473145e-01, 3.764865398406982e-01,&
3512  3.486587703227997e-01, -3.462808132171631e-01, 9.324266910552979e-01, 2.155355364084244e-01,&
3513  -5.171442404389381e-02, 6.311618685722351e-01, -1.088170856237411e-01, 4.840107262134552e-01,&
3514  -2.310744374990463e-01, -3.167505562305450e-01, -2.271509468555450e-01, -2.800688743591309e-01,&
3515  4.713648185133934e-02, -1.575807780027390e-01, 3.583298251032829e-02, -3.308865129947662e-01,&
3516  -2.662795484066010e-01, 1.894978582859039e-01, 7.474141567945480e-02, -1.493624746799469e-01,&
3517  -1.482628136873245e-01, -1.058527529239655e-01, -3.737696707248688e-01, -1.093639135360718e-01,&
3518  -4.270362555980682e-01, 1.249950975179672e-01, -1.971846818923950e-01, 3.135327398777008e-01,&
3519  4.604682624340057e-01, -4.614944458007812e-01, 4.820220768451691e-01, 3.806282877922058e-01,&
3520  3.629744052886963e-01, 3.986520171165466e-01, -2.283873707056046e-01, 1.246029064059258e-01,&
3521  3.940442204475403e-01, 2.390366494655609e-01, 8.402416110038757e-02, 3.498363792896271e-01,&
3522  -3.888027667999268e-01, 2.272991091012955e-01, -3.421411216259003e-01, 1.273499727249146e-01,&
3523  1.342627108097076e-01, 1.159043312072754e-01, 1.274240911006927e-01, -2.915177941322327e-01,&
3524  6.415430903434753e-01, 1.699399948120117e-01, -6.556300520896912e-01, 9.605846554040909e-02,&
3525  3.632318377494812e-01, -3.854629993438721e-01, -3.860571384429932e-01, -1.257066577672958e-01,&
3526  -1.186188161373138e-01, -1.368320286273956e-01, -2.300722897052765e-01, -4.762146174907684e-01,&
3527  -3.621844053268433e-01, -4.978014528751373e-02, -1.940275430679321e-01, -1.588442362844944e-02,&
3528  -1.519876420497894e-01, 1.312368810176849e-01, 1.862339228391647e-01, 6.462548375129700e-01,&
3529  5.544137358665466e-01, -3.416634351015091e-02, 9.995899349451065e-02, -6.969342380762100e-02,&
3530  -1.428494304418564e-01, 2.647481858730316e-01, 1.083492934703827e-01, 5.986538901925087e-02,&
3531  -1.576850377023220e-02, 1.962803453207016e-01, 6.334787011146545e-01, -1.408149152994156e-01,&
3532  -1.756295561790466e-01, -2.156554609537125e-01, -1.412229537963867e-01, -5.801249146461487e-01,&
3533  -5.700040608644485e-02, -3.019523918628693e-01, -1.161280944943428e-01, -3.032382726669312e-01,&
3534  1.140000447630882e-01, -2.648598253726959e-01, -2.016042023897171e-01, -3.181084990501404e-02,&
3535  7.931513339281082e-02, 5.399967432022095e-01, -4.595367014408112e-01, 9.602636098861694e-02,&
3536  -4.730868339538574e-01, 2.077568918466568e-01, -2.257115393877029e-01, 3.216529190540314e-01,&
3537  1.631081402301788e-01, 6.222640164196491e-03, -1.323710232973099e-01, 1.348871737718582e-01,&
3538  1.123578473925591e-01, 5.462109446525574e-01, 5.289056897163391e-01, 5.155519247055054e-01,&
3539  2.748569846153259e-01, -3.125837743282318e-01, -3.262098431587219e-01, -8.945185691118240e-03,&
3540  -4.980920553207397e-01, 5.064374208450317e-01, -1.056439951062202e-01, -3.115973472595215e-01,&
3541  3.343601152300835e-02, -7.157339155673981e-02, 5.459919571876526e-01, 2.175374031066895e-01,&
3542  -2.892075665295124e-02, 1.139620468020439e-01, -4.409461319446564e-01, -4.908669367432594e-02,&
3543  -2.098206430673599e-01, 3.024870157241821e-01, -3.447104394435883e-01, -2.666398882865906e-01,&
3544  -1.739841997623444e-01, -1.120999976992607e-01, 4.268572330474854e-01, 4.144327044487000e-01,&
3545  4.936498403549194e-01, 5.718982815742493e-01, 5.464938655495644e-02, 3.950506746768951e-01,&
3546  -1.432464718818665e-01, -8.016809076070786e-02, 5.947722792625427e-01, -1.419431418180466e-01,&
3547  -2.328271418809891e-01, -1.958254128694534e-01, -9.914696216583252e-03, -1.478249877691269e-01,&
3548  4.182004928588867e-01, 7.797469943761826e-02, 3.761124014854431e-01, 4.066407680511475e-01,&
3549  1.217691525816917e-01, -1.124059110879898e-01, 7.020493596792221e-02, 1.022125557065010e-01,&
3550  -5.025411844253540e-01, -2.482684552669525e-01, -5.819427594542503e-02, -1.587846502661705e-02,&
3551  -1.881837695837021e-01, 4.026338756084442e-01, 3.339109122753143e-01, 2.215891182422638e-01,&
3552  7.083265781402588e-01, -7.670203596353531e-02, 3.171359598636627e-01, 8.310161828994751e-01 &
3553  /), shape(hidden1synapse))
3554 
3555  outputsynapse = reshape((/ &
3556  2.309078276157379e-01, 8.006124198436737e-02, 5.207773447036743e-01, 3.642434999346733e-02,&
3557  -5.444544181227684e-02, -2.300137132406235e-01, 4.965198636054993e-01, -3.590968847274780e-01,&
3558  1.392439752817154e-01, -2.941058278083801e-01, 6.655657291412354e-01, -4.931978881359100e-01,&
3559  -1.253394484519958e-01, 1.540697813034058e-01, 1.752252578735352e-01, 4.873855113983154e-01,&
3560  5.741749405860901e-01, 1.275441497564316e-01, -4.765471443533897e-02, -5.038099363446236e-02,&
3561  -8.334141224622726e-02, 5.842098593711853e-01, -4.490646719932556e-01, -5.416034907102585e-02,&
3562  -2.264686524868011e-01, -1.698177903890610e-01, 3.113179206848145e-01, 4.435532391071320e-01,&
3563  -5.240975022315979e-01, 1.108570247888565e-01, 2.321150526404381e-02, 2.374080866575241e-01,&
3564  -2.570592761039734e-01, 3.205819129943848e-01, -3.468126952648163e-01, 2.772298157215118e-01,&
3565  1.148034259676933e-01, 1.865169033408165e-03, 3.649827241897583e-01, 5.026416182518005e-01,&
3566  -2.502067089080811e-01, -6.028710007667542e-01, -6.978485733270645e-02, 8.656968921422958e-02,&
3567  -5.227651596069336e-01, 9.525942802429199e-02, -1.903700232505798e-01, 1.426358073949814e-01,&
3568  5.602359771728516e-01, -2.479453980922699e-01, 1.296138316392899e-01, -4.612154662609100e-01,&
3569  -4.198251068592072e-01, 6.053315401077271e-01, -1.160371229052544e-01, -4.044520258903503e-01,&
3570  -1.530461944639683e-02, 4.267008602619171e-01, 2.162231802940369e-01, 1.101492717862129e-01,&
3571  -9.195729345083237e-02, -3.771322593092918e-02, 3.320552408695221e-02, -4.979051947593689e-01,&
3572  1.581449210643768e-01, -5.021102428436279e-01, 1.184114068746567e-02, 4.836803376674652e-01,&
3573  -5.539562702178955e-01, -2.782657444477081e-01, -1.547775119543076e-01, 4.582551419734955e-01,&
3574  2.844007611274719e-01, -4.516306817531586e-01, 1.886052638292313e-02, 3.602048456668854e-01,&
3575  4.175081476569176e-02, 2.075715661048889e-01, -5.455711483955383e-01, -2.442489415407181e-01,&
3576  -2.680016458034515e-01, 2.636941149830818e-03, 4.164874255657196e-01, 8.120876550674438e-02,&
3577  -4.927250146865845e-01, -3.254565298557281e-01, 5.583248138427734e-01, -1.608870923519135e-01,&
3578  5.749610066413879e-01, 5.479150414466858e-01, 3.469662666320801e-01, -5.061987638473511e-01,&
3579  3.353976905345917e-01, 2.548734247684479e-01, 2.064624279737473e-01, -5.114225745201111e-01,&
3580  -4.629626572132111e-01, -1.936426460742950e-01, 2.327886223793030e-01, -4.583241790533066e-02,&
3581  -5.125665068626404e-01, 1.089363321661949e-01, -4.951449036598206e-01, -5.018569827079773e-01,&
3582  2.582837454974651e-02, 4.913705959916115e-02, -2.441505938768387e-01, -3.174663335084915e-02,&
3583  -1.644173413515091e-01, -2.947083115577698e-01, -5.097694396972656e-01, 7.136650383472443e-03,&
3584  1.942666023969650e-01, 1.587397605180740e-01, -4.691866040229797e-01, -4.862202703952789e-01,&
3585  1.432444006204605e-01, -4.405085742473602e-01, 3.072859644889832e-01, -4.172921180725098e-01 &
3586  /), shape(outputsynapse))
3587 
3588  END SUBROUTINE breadboard2
3589 !
3590 !------------------------------------------------------------------------------
3591 !
3592  SUBROUTINE breadboard3(inputFile,hidden1Axon,hidden1Synapse,outputSynapse)
3593 
3594  implicit none
3595 
3596  real inputfile(2,7)
3597  real hidden1axon(40)
3598  real hidden1synapse(7,40)
3599  real outputsynapse(40,3)
3600 
3601  inputfile = reshape((/ &
3602  1.077844262123108e+00, -1.778443008661270e-01,&
3603  2.442665100097656e-01, 3.212104737758636e-02,&
3604  2.107975035905838e-01, 6.168988943099976e-01,&
3605  3.646677434444427e-01, 1.214343756437302e-01,&
3606  2.485501170158386e-01, 2.868268489837646e-01,&
3607  1.976718604564667e-01, 4.469360709190369e-01,&
3608  3.208556175231934e-01, -2.509090602397919e-01 &
3609  /), shape(inputfile))
3610 
3611  hidden1axon = &
3612  (/4.393131732940674e-01, -1.290386915206909e-01, 6.327351331710815e-01, 5.494017004966736e-01,&
3613  4.969031810760498e-01, 2.086368650197983e-01, -2.167895883321762e-01, 9.464725255966187e-01,&
3614  1.640024334192276e-01, 2.452306896448135e-01, 1.972979009151459e-01, 9.276027083396912e-01,&
3615  2.502645850181580e-01, 5.485208034515381e-01, -2.839279770851135e-01, 6.810981035232544e-01,&
3616  -2.170253098011017e-01, -3.821973502635956e-01, 8.861125111579895e-01, -6.720829606056213e-01,&
3617  2.960434183478355e-02, -3.987881243228912e-01, -1.057050973176956e-01, 6.963993310928345e-01,&
3618  -1.413413435220718e-01, 7.551014423370361e-01, 1.243001222610474e-02, -3.603826761245728e-01,&
3619  7.450697422027588e-01, 7.630060315132141e-01, 5.904716849327087e-01, -5.035977959632874e-01,&
3620  2.082890830934048e-03, -1.259811818599701e-01, -8.103467822074890e-01, -4.683765172958374e-01,&
3621  -3.666405081748962e-01, -5.880022794008255e-02, -5.269588828086853e-01, -1.594118028879166e-01/)
3622 
3623  hidden1synapse = reshape((/ &
3624  2.258135080337524e-01, -8.417334407567978e-02, -6.296884268522263e-02, -1.971755474805832e-01,&
3625  -2.008096426725388e-01, 1.312222182750702e-01, -2.187249064445496e-01, 3.300825655460358e-01,&
3626  -1.458171010017395e-01, -2.447441816329956e-01, 2.373344898223877e-01, -3.369296491146088e-01,&
3627  -2.142974138259888e-01, 7.442125119268894e-03, 2.400149852037430e-01, 5.063241720199585e-01,&
3628  1.461273133754730e-01, 3.199279010295868e-01, 2.184794545173645e-01, 6.378577351570129e-01,&
3629  2.826454937458038e-01, 1.467282772064209e-01, 4.167218208312988e-01, 3.410821408033371e-02,&
3630  -1.507616639137268e-01, 1.607457697391510e-01, 1.063031926751137e-01, 4.860900044441223e-01,&
3631  -7.546984404325485e-02, 3.811344206333160e-01, -3.500247746706009e-02, -3.294828236103058e-01,&
3632  -2.355449087917805e-02, 3.319101631641388e-01, 1.341840159147978e-02, -2.975183129310608e-01,&
3633  -2.044427692890167e-01, 7.903610914945602e-02, -2.241216152906418e-01, -1.982768028974533e-01,&
3634  2.166045308113098e-01, -3.769811093807220e-01, -4.219292849302292e-02, -4.683617055416107e-01,&
3635  1.365721821784973e-01, -5.708352923393250e-01, -5.482509136199951e-01, -5.697317123413086e-01,&
3636  3.948671817779541e-01, 4.008982181549072e-01, -6.056785583496094e-01, -6.540334783494473e-03,&
3637  -4.144128859043121e-01, -9.239719808101654e-02, 1.977843493223190e-01, -2.407579571008682e-01,&
3638  -2.472878843545914e-01, -3.429937064647675e-01, -1.058190166950226e-01, -8.456809073686600e-02,&
3639  4.944565296173096e-01, 4.329789280891418e-01, 2.303941249847412e-01, 2.076211571693420e-01,&
3640  1.421037223190069e-02, 5.740813165903091e-02, 1.577541381120682e-01, 1.072699949145317e-01,&
3641  3.550452180206776e-03, -7.603026926517487e-02, 1.787180006504059e-01, 3.000865578651428e-01,&
3642  -4.790667295455933e-01, -1.263711899518967e-01, -1.886992603540421e-01, -1.971553862094879e-01,&
3643  -4.320513010025024e-01, -1.786982715129852e-01, -3.415124714374542e-01, 3.517304956912994e-01,&
3644  3.841716647148132e-01, 1.595797836780548e-01, 1.466515809297562e-01, 3.235963284969330e-01,&
3645  3.831133618950844e-02, 3.778985887765884e-02, 4.742037355899811e-01, -1.204959601163864e-01,&
3646  -6.766954064369202e-02, 4.763844013214111e-01, 2.847502529621124e-01, -2.614455521106720e-01,&
3647  4.211461246013641e-01, 2.459102123975754e-01, -3.291262984275818e-01, 4.159525930881500e-01,&
3648  1.433917880058289e-01, 5.506788492202759e-01, -4.396528601646423e-01, 3.432570993900299e-01,&
3649  -4.605481028556824e-01, -1.657515168190002e-01, 2.847986221313477e-01, -3.968485295772552e-01,&
3650  2.652311325073242e-01, 2.413431182503700e-03, 6.885899305343628e-01, -1.771224141120911e-01,&
3651  -2.605379931628704e-02, 1.681880354881287e-01, 4.201361536979675e-01, -2.905318737030029e-01,&
3652  -1.065197512507439e-01, 2.377779632806778e-01, 3.171224892139435e-01, -5.171843245625496e-02,&
3653  8.248845487833023e-02, -4.904226213693619e-02, 3.065647780895233e-01, 1.610077768564224e-01,&
3654  8.712385892868042e-01, 3.008154034614563e-01, 5.729283690452576e-01, -1.608658432960510e-01,&
3655  -3.810124993324280e-01, 6.462811827659607e-01, -2.662218213081360e-01, -5.297539830207825e-01,&
3656  -1.356185525655746e-01, 2.623566091060638e-01, -1.624718308448792e-01, -2.004417479038239e-01,&
3657  -3.377428650856018e-02, 3.970716595649719e-01, -1.560127288103104e-01, 4.747187346220016e-02,&
3658  -3.162815868854523e-01, -3.350041508674622e-01, -3.987393081188202e-01, -4.969080090522766e-01,&
3659  -1.142657846212387e-01, -7.119160890579224e-01, 1.153976768255234e-01, -6.001577973365784e-01,&
3660  -3.606468439102173e-01, -3.741255104541779e-01, -7.550917863845825e-01, 1.106901541352272e-01,&
3661  -1.475569456815720e-01, -2.016223073005676e-01, -2.226002812385559e-01, 2.520006597042084e-01,&
3662  -4.015582501888275e-01, -6.874573230743408e-01, -3.860632777214050e-01, 1.074488908052444e-01,&
3663  -3.594025373458862e-01, -2.556712925434113e-01, 2.491754293441772e-01, -1.749203801155090e-01,&
3664  -5.133146420121193e-03, -2.629097700119019e-01, 1.706630140542984e-01, 5.300921797752380e-01,&
3665  3.016012907028198e-01, 3.024738729000092e-01, 1.334729231894016e-02, 3.605858981609344e-01,&
3666  -3.797290921211243e-01, 2.125910073518753e-01, -3.324515819549561e-01, -2.657738924026489e-01,&
3667  8.549436926841736e-02, 2.843597829341888e-01, -1.628004312515259e-01, 4.068509638309479e-01,&
3668  -1.096388697624207e-01, 1.842555999755859e-01, -2.429902255535126e-01, 1.793259531259537e-01,&
3669  6.289024949073792e-01, 4.427114427089691e-01, -8.943214267492294e-02, 1.407862901687622e-01,&
3670  -4.747562706470490e-01, 1.607088744640350e-01, 2.691341638565063e-01, -1.326033025979996e-01,&
3671  -6.888723373413086e-02, 3.347525000572205e-01, 2.391179502010345e-01, -7.601787149906158e-02,&
3672  3.946174979209900e-01, 4.608300328254700e-01, -4.973608553409576e-01, 2.180006355047226e-02,&
3673  -2.155515551567078e-01, 4.018128812313080e-01, 5.872810482978821e-01, -2.970355451107025e-01,&
3674  6.164746284484863e-01, -2.832284271717072e-01, -7.214747369289398e-02, 3.505393862724304e-01,&
3675  3.504253327846527e-01, -3.037774860858917e-01, -3.341494500637054e-01, -2.143821418285370e-01,&
3676  3.230984508991241e-01, -6.691335439682007e-01, -1.196009963750839e-01, 2.609530091285706e-01,&
3677  6.332063078880310e-01, -2.495922595262527e-01, -1.421163380146027e-01, 4.370761811733246e-01,&
3678  2.344440817832947e-01, -4.770855009555817e-01, -1.213536486029625e-01, -4.947537779808044e-01,&
3679  2.018401175737381e-01, -3.219321966171265e-01, -1.836685538291931e-01, 6.838442683219910e-01,&
3680  -5.349717736244202e-01, 5.601373910903931e-01, -3.152181506156921e-01, 2.578000128269196e-01,&
3681  4.295753240585327e-01, -1.423847377300262e-01, 6.693964004516602e-01, -2.671292051672935e-02,&
3682  -2.906464338302612e-01, -6.406581997871399e-01, -5.139582753181458e-01, 2.622411847114563e-01,&
3683  2.534431815147400e-01, -1.518065035343170e-01, -4.292866215109825e-02, 4.628975689411163e-01,&
3684  1.969320774078369e-01, 4.264309704303741e-01, -4.475159347057343e-01, -5.727919340133667e-01,&
3685  5.388451814651489e-01, -2.982297539710999e-01, -3.593768924474716e-02, -1.298359930515289e-01,&
3686  -4.535509645938873e-01, -1.963836848735809e-01, -2.640297412872314e-01, 3.889253437519073e-01,&
3687  -2.371201291680336e-02, 5.441716909408569e-01, -3.557947278022766e-01, -1.912423074245453e-01,&
3688  3.168485462665558e-01, -3.096546828746796e-01, 2.481035888195038e-01, 2.293358147144318e-01,&
3689  -7.027690410614014e-01, -4.839945435523987e-01, -2.963027358055115e-01, -5.126427412033081e-01,&
3690  2.138081789016724e-01, -2.071801871061325e-01, -9.827529639005661e-02, -4.680003225803375e-01,&
3691  -3.230824470520020e-01, -2.535474896430969e-01, 2.779140770435333e-01, -5.119556188583374e-01,&
3692  1.893053054809570e-01, -5.211792513728142e-02, 4.212611019611359e-01, -5.767111182212830e-01,&
3693  3.436119556427002e-01, 1.560586243867874e-01, -1.338404417037964e-01, 2.465801686048508e-01 &
3694  /), shape(hidden1synapse))
3695 
3696  outputsynapse = reshape((/ &
3697  -1.504478603601456e-01, 8.304652571678162e-02, 2.053809165954590e-01, 4.613898992538452e-01,&
3698  3.307471871376038e-01, -2.503668665885925e-01, -4.260648787021637e-01, -2.033478170633316e-01,&
3699  1.205723360180855e-01, 3.727485835552216e-01, -2.320208251476288e-01, 4.672348499298096e-01,&
3700  -1.567042618989944e-01, 4.181037843227386e-01, -2.018750756978989e-01, 2.649243474006653e-01,&
3701  2.292609065771103e-01, 2.745892405509949e-01, 2.554303109645844e-01, -3.891312777996063e-01,&
3702  -4.561745524406433e-01, -3.781261444091797e-01, -2.881123721599579e-01, 2.764029800891876e-01,&
3703  8.924255520105362e-02, 4.471623599529266e-01, 9.589984267950058e-02, 4.323486387729645e-01,&
3704  4.792469739913940e-01, -9.918873012065887e-02, 4.427296221256256e-01, 3.841804563999176e-01,&
3705  1.890532523393631e-01, -4.477364718914032e-01, -2.994475699961185e-02, -7.976207137107849e-02,&
3706  2.607934474945068e-01, -3.710708916187286e-01, -2.811897993087769e-01, 6.034602597355843e-02,&
3707  4.014556109905243e-01, 2.982565164566040e-01, 4.447779953479767e-01, -3.612459823489189e-02,&
3708  -2.895380258560181e-01, 2.155442684888840e-01, -3.415147066116333e-01, 4.278375506401062e-01,&
3709  1.896717213094234e-02, -9.841635823249817e-02, 1.671093255281448e-01, 3.151571452617645e-01,&
3710  -1.678100675344467e-01, -4.435905069112778e-02, -2.333792001008987e-01, 4.360995292663574e-01,&
3711  3.587894737720490e-01, -1.017290875315666e-01, 1.382773071527481e-01, -3.980610668659210e-01,&
3712  -2.268472909927368e-01, -2.996328286826611e-02, 2.546367645263672e-01, 1.532198935747147e-01,&
3713  -1.018586382269859e-02, 3.147244155406952e-01, -3.700032234191895e-01, 2.747226655483246e-01,&
3714  4.799823760986328e-01, 3.735623657703400e-01, 3.757937550544739e-01, -5.869687348604202e-02,&
3715  7.807171344757080e-02, -1.428240090608597e-01, -5.030028820037842e-01, -4.323083460330963e-01,&
3716  -2.643692195415497e-01, -4.277939200401306e-01, 3.172474205493927e-01, -4.587580561637878e-01,&
3717  4.488629996776581e-01, -1.273735053837299e-02, 2.275637537240982e-01, 2.276848852634430e-01,&
3718  1.995900124311447e-01, -1.224325075745583e-01, -1.321871429681778e-01, 4.938367307186127e-01,&
3719  3.713837862014771e-01, 4.943797290325165e-01, -8.973516523838043e-02, 3.630679845809937e-01,&
3720  3.118912279605865e-01, 3.763218820095062e-01, -2.658533453941345e-01, 5.210888572037220e-03,&
3721  -3.098636865615845e-01, -4.516429603099823e-01, 3.575363755226135e-01, 3.780608177185059e-01,&
3722  3.606519103050232e-01, 4.404914379119873e-01, -4.452764391899109e-01, 2.741447389125824e-01,&
3723  1.122588440775871e-01, 2.581178247928619e-01, -2.986721992492676e-01, -3.506239950656891e-01,&
3724  -4.466909915208817e-02, 1.343552619218826e-01, -2.677312493324280e-02, -5.070485472679138e-01,&
3725  -5.414816737174988e-01, 3.392856195569038e-02, -4.090670943260193e-01, 2.741051837801933e-02,&
3726  7.242175936698914e-02, 4.587205946445465e-01, -2.530987001955509e-02, 1.304957270622253e-02 &
3727  /), shape(outputsynapse))
3728 
3729  END SUBROUTINE breadboard3
3730 !
3731 !------------------------------------------------------------------------------
3732 !
3733  SUBROUTINE breadboard4(inputFile,hidden1Axon,hidden1Synapse,outputSynapse)
3734 
3735  implicit none
3736 
3737  real inputfile(2,7)
3738  real hidden1axon(40)
3739  real hidden1synapse(7,40)
3740  real outputsynapse(40,3)
3741 
3742  inputfile = reshape((/ &
3743  1.077844262123108e+00, -1.778443008661270e-01,&
3744  2.296211272478104e-01, 6.142363324761391e-02,&
3745  2.128665894269943e-01, 6.552034020423889e-01,&
3746  3.361344337463379e-01, 4.151264205574989e-02,&
3747  2.430133521556854e-01, 3.004860281944275e-01,&
3748  1.976718604564667e-01, 4.469360709190369e-01,&
3749  1.951007992029190e-01, -4.725341200828552e-01 &
3750  /), shape(inputfile))
3751 
3752  hidden1axon = &
3753  (/-1.700838446617126e+00, 1.409139156341553e+00, -1.263895153999329e+00, -1.653346180915833e+00,&
3754  -1.753814935684204e+00, 1.510319232940674e+00, -1.652730584144592e+00, 1.968622922897339e+00,&
3755  -1.764715671539307e+00, -1.920537590980530e+00, 1.703584432601929e+00, 9.688673615455627e-01,&
3756  1.621924757957458e+00, -1.195185184478760e+00, -1.170735836029053e+00, -1.726262569427490e+00,&
3757  1.693020582199097e+00, -1.789734363555908e+00, 2.076834440231323e+00, -2.054785251617432e+00,&
3758  1.735462069511414e+00, -1.377997517585754e+00, 1.685962557792664e+00, -1.505226492881775e+00,&
3759  1.329061865806580e+00, -1.970339655876160e+00, 1.326048374176025e+00, -1.803932785987854e+00,&
3760  -1.356570959091187e+00, -7.451403737068176e-01, 1.977797389030457e+00, 1.962222456932068e+00,&
3761  -1.924186825752258e+00, -1.927103757858276e+00, 1.772511124610901e+00, 2.267752170562744e+00,&
3762  1.343345522880554e+00, -1.727791309356689e+00, -1.688525199890137e+00, -2.020093202590942e+00/)
3763 
3764  hidden1synapse = reshape((/ &
3765  -3.217298686504364e-01, -1.535140275955200e-01, -9.374593496322632e-01, -3.773699328303337e-02,&
3766  -7.610699534416199e-01, 1.124547328799963e-03, 7.987623810768127e-01, 5.171887874603271e-01,&
3767  1.182283610105515e-01, 1.252476930618286e+00, -2.393243610858917e-01, 8.846385776996613e-02,&
3768  4.983871877193451e-01, -1.072657704353333e+00, -5.902777314186096e-01, 3.053096830844879e-01,&
3769  -1.245228290557861e+00, -9.408684819936752e-02, -1.261333227157593e+00, 7.626018673181534e-02,&
3770  -3.566111624240875e-01, -2.651087939739227e-01, 5.490935966372490e-02, -1.231116533279419e+00,&
3771  -3.552156984806061e-01, -4.995369017124176e-01, -1.970071047544479e-01, 6.921592950820923e-01,&
3772  -7.216929793357849e-01, -3.322352096438408e-02, -1.040984153747559e+00, -2.749272584915161e-01,&
3773  -3.936901688575745e-01, -5.485629439353943e-01, 2.315377295017242e-01, 3.925201594829559e-01,&
3774  2.289973348379135e-01, 9.091649055480957e-01, -2.400987595319748e-01, 2.274930775165558e-01,&
3775  7.657364010810852e-01, -4.531333744525909e-01, -3.045647442340851e-01, -1.612837314605713e-01,&
3776  -6.530205607414246e-01, 6.988145411014557e-02, -3.664937913417816e-01, -1.209497332572937e+00,&
3777  1.716423481702805e-01, 2.888691425323486e-01, -6.977611780166626e-01, 1.001697182655334e+00,&
3778  -3.773393929004669e-01, -3.817198425531387e-02, 3.071420192718506e-01, -1.018374800682068e+00,&
3779  -3.812201619148254e-01, 2.521711289882660e-01, -1.311386704444885e+00, -4.305998682975769e-01,&
3780  -2.096824795007706e-01, -6.536886692047119e-01, 9.946095943450928e-02, -8.006195425987244e-01,&
3781  6.314782798290253e-02, -9.162106513977051e-01, 1.249427199363708e-01, -1.967987567186356e-01,&
3782  -2.837883234024048e-01, 4.405716657638550e-01, 7.357195615768433e-01, 2.873047888278961e-01,&
3783  7.006355524063110e-01, -2.267676740884781e-01, 1.684177815914154e-01, 2.451081871986389e-01,&
3784  -6.897705197334290e-01, -1.359052062034607e-01, -1.217865824699402e+00, 6.268809437751770e-01,&
3785  -1.108817100524902e+00, -1.098538115620613e-01, 6.363938003778458e-02, -2.163156747817993e+00,&
3786  2.993230819702148e-01, -6.225543469190598e-02, 6.338689923286438e-01, 2.340336740016937e-01,&
3787  3.334980309009552e-01, 5.768545866012573e-01, -8.454492688179016e-01, -7.557854652404785e-01,&
3788  -6.227542161941528e-01, -1.105716824531555e+00, 2.116404175758362e-01, -2.117430865764618e-01,&
3789  -1.036560058593750e+00, -1.257222741842270e-01, 5.264365077018738e-01, -1.787502527236938e+00,&
3790  -6.102513074874878e-01, -1.036811590194702e+00, -1.041777491569519e+00, 6.762499362230301e-02,&
3791  -1.829331994056702e+00, -1.342972517013550e-01, 2.181535959243774e+00, 7.125011086463928e-01,&
3792  9.849542975425720e-01, 4.515964090824127e-01, -5.667360424995422e-01, 1.371907234191895e+00,&
3793  4.193291962146759e-01, -4.483173191547394e-01, 1.056447148323059e+00, -4.035096466541290e-01,&
3794  2.473213225603104e-01, 4.283659458160400e-01, -1.105738878250122e+00, -3.882422149181366e-01,&
3795  1.359030008316040e-01, -1.316889882087708e+00, 1.206199750304222e-01, -2.816296517848969e-01,&
3796  -3.856543898582458e-01, -1.341159194707870e-01, 2.931591272354126e-01, -8.115946650505066e-01,&
3797  1.549627929925919e-01, -3.494594991207123e-02, 1.392071247100830e-01, 8.500702381134033e-01,&
3798  -1.105314135551453e+00, -8.855208158493042e-01, -1.129539161920547e-01, -7.288187742233276e-01,&
3799  2.031663209199905e-01, -2.040854692459106e-01, -2.651244997978210e-01, 6.747405529022217e-01,&
3800  6.289814710617065e-01, 3.702930510044098e-01, 8.955963253974915e-01, -1.791490912437439e-01,&
3801  6.291658878326416e-01, 3.181912600994110e-01, -7.458741664886475e-01, -5.797970294952393e-01,&
3802  8.048549294471741e-03, -1.517996788024902e+00, 1.586797833442688e-02, -1.968807131052017e-01,&
3803  -6.696819067001343e-01, 2.561997175216675e-01, 1.585537791252136e-01, -3.939553797245026e-01,&
3804  1.001605153083801e+00, -3.178015723824501e-02, 2.169712930917740e-01, 7.597719430923462e-01,&
3805  -8.711787462234497e-01, -2.590858340263367e-01, -4.994206726551056e-01, -1.350332260131836e+00,&
3806  -1.754350513219833e-01, -5.298053622245789e-01, -1.044484019279480e+00, -5.103482306003571e-02,&
3807  8.845404386520386e-01, 4.584137201309204e-01, 1.076861619949341e+00, 1.874905377626419e-01,&
3808  2.787777185440063e-01, 8.369036912918091e-01, -8.217707276344299e-01, -2.826712131500244e-01,&
3809  -2.450734227895737e-01, -8.279343843460083e-01, 3.510917425155640e-01, -3.488889932632446e-01,&
3810  -7.627615332603455e-01, 3.606846034526825e-01, 5.258455872535706e-01, -5.099301040172577e-02,&
3811  6.352093815803528e-01, -1.835833787918091e-01, 1.247637987136841e+00, 5.917957425117493e-01,&
3812  1.019452288746834e-01, -5.673841834068298e-01, 1.377126276493073e-01, -1.055184245109558e+00,&
3813  -2.036373913288116e-01, -6.316062808036804e-01, -3.354403078556061e-01, 3.826665878295898e-01,&
3814  -6.721435189247131e-01, -6.410418748855591e-01, -1.417969822883606e+00, -8.955898880958557e-02,&
3815  -6.617363095283508e-01, -6.313887238502502e-01, 1.284139454364777e-01, -7.438000291585922e-02,&
3816  3.091568231582642e+00, 8.395515084266663e-01, 7.227233052253723e-01, 8.192335367202759e-01,&
3817  -2.106423974037170e-01, 2.122008800506592e+00, 7.060149908065796e-01, 3.394779860973358e-01,&
3818  6.117095947265625e-01, -3.271679580211639e-01, 1.616740077733994e-01, 1.569840312004089e-01,&
3819  -1.123665213584900e+00, 3.844760954380035e-01, 2.845884263515472e-01, 7.137780785560608e-01,&
3820  1.460106819868088e-01, -1.021391227841377e-01, 5.172263383865356e-01, -7.423986196517944e-01,&
3821  -2.789774909615517e-02, -1.258952766656876e-01, -1.325458526611328e+00, -5.270438194274902e-01,&
3822  -3.967397287487984e-02, -2.709308564662933e-01, 1.340401768684387e-01, -6.963784694671631e-01,&
3823  -3.221498429775238e-01, -8.531031608581543e-01, 3.377375304698944e-01, 1.652107536792755e-01,&
3824  -3.512997031211853e-01, -1.630981415510178e-01, 3.690161705017090e-01, 1.549807284027338e-02,&
3825  1.193455934524536e+00, 2.675475478172302e-01, 3.856497108936310e-01, 9.223973155021667e-01,&
3826  -8.005780726671219e-02, 7.949089407920837e-01, 1.678814589977264e-01, 5.589793920516968e-01,&
3827  -2.890521883964539e-01, -6.459630280733109e-02, 1.577395349740982e-01, -6.019581556320190e-01,&
3828  1.361452788114548e-01, -1.461234450340271e+00, 2.132855653762817e-01, -7.116237878799438e-01,&
3829  -1.837224513292313e-01, 6.981704831123352e-01, -1.456485867500305e+00, -8.896524459123611e-02,&
3830  -6.985316872596741e-01, -9.188821911811829e-01, -1.798982769250870e-01, -3.445543348789215e-01,&
3831  -9.767906665802002e-01, 6.575983762741089e-01, -5.698328614234924e-01, 2.794421613216400e-01,&
3832  -9.889149665832520e-01, 2.113757282495499e-01, -4.894487261772156e-01, -9.110729694366455e-01,&
3833  3.156659901142120e-01, -8.372070193290710e-01, 1.710339263081551e-02, -7.162731885910034e-01,&
3834  -9.848624467849731e-02, -2.407071143388748e-01, -4.630023241043091e-01, 5.028110146522522e-01 &
3835  /), shape(hidden1synapse))
3836 
3837  outputsynapse = reshape((/ &
3838  -1.209702730178833e+00, 1.183213353157043e+00, -1.019356846809387e+00, -1.344744205474854e+00,&
3839  -1.445307731628418e+00, 1.024327754974365e+00, -1.584630727767944e+00, 1.083521246910095e+00,&
3840  -1.308865427970886e+00, -1.247952342033386e+00, 1.239847064018250e+00, 1.287056356668472e-01,&
3841  9.846584796905518e-01, -1.553632378578186e+00, -1.231866717338562e+00, 4.489912092685699e-02,&
3842  1.253254055976868e+00, -1.430614471435547e+00, 1.041161060333252e+00, -1.605084300041199e+00,&
3843  1.527578949928284e+00, -1.474965572357178e+00, 1.355290770530701e+00, -1.745877861976624e+00,&
3844  1.712602972984314e+00, -1.563431382179260e+00, 8.333104252815247e-01, -1.541154265403748e+00,&
3845  -1.556280970573425e+00, 7.898001670837402e-01, 1.451943874359131e+00, 1.376102089881897e+00,&
3846  -1.475358963012695e+00, -1.508958697319031e+00, 1.723131775856018e+00, 1.577485084533691e+00,&
3847  2.009120136499405e-01, -1.543342947959900e+00, -1.532042622566223e+00, -1.665173649787903e+00,&
3848  -1.577844977378845e+00, 1.509271860122681e+00, -1.648273229598999e+00, -1.399203181266785e+00,&
3849  -1.230364322662354e+00, 1.090018987655640e+00, -7.097014784812927e-01, 1.677408456802368e+00,&
3850  -1.743194699287415e+00, -1.423129081726074e+00, 7.856354713439941e-01, 1.262704372406006e+00,&
3851  1.029602646827698e+00, -8.157435655593872e-01, -1.168590903282166e+00, -1.007120013237000e+00,&
3852  1.498046159744263e+00, -1.094031929969788e+00, 1.288908720016479e+00, -1.570232629776001e+00,&
3853  1.331548571586609e+00, -1.591911792755127e+00, 1.173869848251343e+00, -1.569446206092834e+00,&
3854  1.071457147598267e+00, -1.386015534400940e+00, 1.319629669189453e+00, -1.251965403556824e+00,&
3855  -1.506981730461121e+00, -5.631150603294373e-01, 1.476744890213013e+00, 1.224819302558899e+00,&
3856  -1.190375804901123e+00, -4.876171946525574e-01, 1.674062848091125e+00, 1.343202710151672e+00,&
3857  8.375900387763977e-01, -1.624152183532715e+00, -1.477828741073608e+00, -1.320914030075073e+00,&
3858  -1.082759499549866e+00, 1.309733152389526e+00, -5.913071632385254e-01, -1.292264103889465e+00,&
3859  -1.440814852714539e+00, 1.020094513893127e+00, -1.208431601524353e+00, 1.691915869712830e+00,&
3860  -1.277797341346741e+00, -1.482174158096313e+00, 1.266713261604309e+00, 1.296367645263672e+00,&
3861  1.238657712936401e+00, -7.025628685951233e-01, 2.491326481103897e-01, -1.536825418472290e+00,&
3862  1.577931523323059e+00, -1.065637469291687e+00, 1.696800708770752e+00, -1.695444345474243e+00,&
3863  1.581656932830811e+00, -1.088520646095276e+00, 1.492973804473877e+00, -1.063908934593201e+00,&
3864  1.496415257453918e+00, -1.486176609992981e+00, 6.039925217628479e-01, -1.485497832298279e+00,&
3865  -1.147870540618896e+00, -1.266431331634521e+00, 1.607187867164612e+00, 1.494379520416260e+00,&
3866  -1.001191616058350e+00, -1.084854602813721e+00, 1.410489916801453e+00, 1.581320643424988e+00,&
3867  1.205576062202454e+00, -1.245357394218445e+00, -1.343545675277710e+00, -1.709581851959229e+00 &
3868  /), shape(outputsynapse))
3869 
3870  END SUBROUTINE breadboard4
3871 !
3872 !------------------------------------------------------------------------------
3873 !
3874  SUBROUTINE breadboard5(inputFile,hidden1Axon,hidden1Synapse,outputSynapse)
3875 
3876  implicit none
3877 
3878  real inputfile(2,7)
3879  real hidden1axon(40)
3880  real hidden1synapse(7,40)
3881  real outputsynapse(40,3)
3882 
3883  inputfile = reshape((/ &
3884  1.077844262123108e+00, -1.778443008661270e-01,&
3885  2.188449800014496e-01, 1.674167998135090e-02,&
3886  1.918158382177353e-01, 6.903452277183533e-01,&
3887  3.361344337463379e-01, 4.151264205574989e-02,&
3888  2.485501170158386e-01, 2.868268489837646e-01,&
3889  1.839550286531448e-01, 3.534696102142334e-01,&
3890  1.951007992029190e-01, -4.725341200828552e-01 &
3891  /), shape(inputfile))
3892 
3893  hidden1axon = &
3894  (/3.177257776260376e-01, -3.444353640079498e-01, 5.270494818687439e-01, -5.221590399742126e-01,&
3895  -2.202716171741486e-01, -4.241476655006409e-01, 2.620704658329487e-02, 6.034846901893616e-01,&
3896  -3.619376122951508e-01, -3.380794525146484e-01, 4.901479184627533e-02, 4.951947927474976e-02,&
3897  1.800213754177094e-01, -2.407073378562927e-01, -3.286456167697906e-01, -6.795548200607300e-01,&
3898  -5.868792533874512e-01, -3.454326987266541e-01, 1.429300457239151e-01, -2.292728424072266e-01,&
3899  4.302643239498138e-01, -2.324737906455994e-01, -4.539224207401276e-01, 5.544423460960388e-01,&
3900  -4.054053127765656e-01, -1.476568281650543e-01, -2.141656428575516e-01, 1.077265888452530e-01,&
3901  5.846756696701050e-01, 3.272875547409058e-01, 1.847147941589355e-03, -4.990870654582977e-01,&
3902  1.531988829374313e-01, 1.791626960039139e-01, -6.736395359039307e-01, -5.093495845794678e-01,&
3903  -6.099227815866470e-02, 3.861090838909149e-01, -6.592265367507935e-01, -2.490588128566742e-01/)
3904 
3905  hidden1synapse = reshape((/ &
3906  3.541271016001701e-02, -7.549672126770020e-01, -4.738137125968933e-01, -2.348672598600388e-03,&
3907  -2.733762562274933e-01, -8.357829414308071e-03, -8.771334886550903e-01, -2.402636408805847e-01,&
3908  -3.840126693248749e-01, -5.802615284919739e-01, 1.073393039405346e-03, -2.714654207229614e-01,&
3909  -1.682563573122025e-01, 2.412795424461365e-01, 6.722061038017273e-01, -2.907541096210480e-01,&
3910  1.961677670478821e-01, -3.303197622299194e-01, 1.424128562211990e-01, 5.971218943595886e-01,&
3911  -3.415485620498657e-01, -3.709296286106110e-01, 2.636498510837555e-01, -6.461778879165649e-01,&
3912  -4.282482266426086e-01, -1.192058548331261e-01, -7.758595943450928e-01, -4.671352729201317e-02,&
3913  -2.137460708618164e-01, -1.528403162956238e-02, -7.986806631088257e-01, -3.911508247256279e-02,&
3914  -5.328277871012688e-02, -6.519866585731506e-01, 3.402085006237030e-01, 1.100756451487541e-01,&
3915  6.820629835128784e-01, 7.288114726543427e-02, 2.484970390796661e-01, -1.383271068334579e-01,&
3916  1.246754452586174e-01, 6.508666276931763e-01, 3.158373534679413e-01, -5.986170172691345e-01,&
3917  6.103343367576599e-01, -6.012113094329834e-01, -1.359632611274719e-01, -2.586761862039566e-02,&
3918  -4.111338853836060e-01, 1.772232651710510e-01, -6.230232119560242e-01, 3.960133790969849e-01,&
3919  -6.472764015197754e-01, -3.764366805553436e-01, -9.892498701810837e-02, -9.984154999256134e-02,&
3920  -4.294761717319489e-01, -2.304461598396301e-01, -7.071238160133362e-01, -4.068204462528229e-01,&
3921  -4.626799225807190e-01, -3.020684123039246e-01, 6.521416902542114e-01, 1.521919965744019e-01,&
3922  -7.091572284698486e-01, -4.207086861133575e-01, -5.045717954635620e-01, -3.018378615379333e-01,&
3923  -4.485827982425690e-01, -5.111956596374512e-01, -8.567054569721222e-02, 4.856635630130768e-01,&
3924  2.459491789340973e-01, -1.496585756540298e-01, -1.183001995086670e-01, 4.713786244392395e-01,&
3925  -2.809847891330719e-01, 8.547450602054596e-02, -3.530589640140533e-01, -7.254429459571838e-01,&
3926  -1.860966980457306e-01, -6.639543771743774e-01, 4.769657552242279e-01, -7.412918210029602e-01,&
3927  3.024796843528748e-01, -6.272576451301575e-01, -5.452296733856201e-01, -2.242822349071503e-01,&
3928  -3.738160133361816e-01, 3.284691274166107e-01, -4.564896821975708e-01, 2.556349933147430e-01,&
3929  4.318492487072945e-02, -1.320876032114029e-01, -9.898099303245544e-02, 6.774403899908066e-02,&
3930  1.919083893299103e-01, 2.400640696287155e-01, 4.077304899692535e-01, 2.524036169052124e-01,&
3931  5.042297840118408e-01, 2.886471152305603e-01, -1.700776815414429e-01, -2.435589283704758e-01,&
3932  -2.057165205478668e-01, 1.996059715747833e-01, 2.711705565452576e-01, 3.861612975597382e-01,&
3933  -2.083975523710251e-01, 7.296724617481232e-02, -2.396509945392609e-01, -1.525006294250488e-01,&
3934  -4.502384066581726e-01, -5.351938009262085e-01, -3.890139460563660e-01, 1.700514107942581e-01,&
3935  -4.677065312862396e-01, -3.514041006565094e-01, 4.196007549762726e-01, 2.812465429306030e-01,&
3936  -2.938374876976013e-01, -3.160441517829895e-01, -4.980419874191284e-01, 3.127529323101044e-01,&
3937  2.271771281957626e-01, -1.466843336820602e-01, -6.397774219512939e-01, 4.446669816970825e-01,&
3938  8.942086249589920e-02, 9.681937843561172e-02, -5.533168092370033e-02, -4.528337121009827e-01,&
3939  6.882410049438477e-01, -3.133308887481689e-01, -2.058080136775970e-01, -2.226170003414154e-01,&
3940  -2.296325266361237e-01, -2.966837584972382e-01, -3.301460444927216e-01, -3.557955026626587e-01,&
3941  3.304032683372498e-01, -8.399857580661774e-02, 4.199078381061554e-01, 1.194518618285656e-02,&
3942  7.232509851455688e-01, 9.784302115440369e-02, -1.134829670190811e-01, 1.034526005387306e-01,&
3943  -8.523296117782593e-01, 5.190717577934265e-01, 5.323929339647293e-02, 1.697375029325485e-01,&
3944  5.581731796264648e-01, -9.171869754791260e-01, -1.815564483404160e-01, 3.742720186710358e-01,&
3945  -2.523972094058990e-01, 1.490504741668701e-01, -6.334505081176758e-01, 2.519290745258331e-01,&
3946  2.056387513875961e-01, -1.307390183210373e-01, -9.355121254920959e-01, -2.585434913635254e-01,&
3947  -4.636541008949280e-02, -1.257960349321365e-01, 1.712975054979324e-01, -7.756385207176208e-01,&
3948  -2.476336807012558e-01, 2.972539961338043e-01, 4.443784654140472e-01, 4.029458761215210e-02,&
3949  -2.695891633629799e-02, -1.858536303043365e-01, -1.682455986738205e-01, -1.443968862295151e-01,&
3950  3.042537868022919e-01, -4.171138703823090e-01, -1.896526068449020e-01, 1.934753060340881e-01,&
3951  -5.211362838745117e-01, -4.224704951047897e-02, -5.408123731613159e-01, -2.546814382076263e-01,&
3952  -3.727044463157654e-01, -4.361395835876465e-01, 1.507636755704880e-01, 8.203987777233124e-02,&
3953  1.366124451160431e-01, 5.710709095001221e-01, 3.028809726238251e-01, 9.636782407760620e-01,&
3954  -3.770071640610695e-02, 3.973050415515900e-01, 2.884645946323872e-03, -8.364310860633850e-01,&
3955  5.341901779174805e-01, -1.418879022821784e-03, 5.416565537452698e-01, 3.877540528774261e-01,&
3956  -1.585132908076048e-03, 1.770619601011276e-01, 4.701207578182220e-02, 4.187163114547729e-01,&
3957  9.934148788452148e-01, 2.260543704032898e-01, 7.113759517669678e-01, 4.728879332542419e-01,&
3958  -3.471966087818146e-01, 7.732371240854263e-02, -2.182047963142395e-01, 8.698941469192505e-01,&
3959  6.959328651428223e-01, 1.184082403779030e-01, 1.408587545156479e-01, 2.005882859230042e-01,&
3960  3.091167509555817e-01, -1.955157965421677e-01, -2.792426571249962e-02, -7.336559891700745e-02,&
3961  1.834385395050049e-01, -3.164150416851044e-01, -5.837532281875610e-01, 9.843266010284424e-01,&
3962  -5.053303837776184e-01, 9.432902336120605e-01, 2.762463316321373e-02, 3.678649663925171e-01,&
3963  -8.084134012460709e-02, 2.041484862565994e-01, 5.061163306236267e-01, 7.991071939468384e-01,&
3964  2.264233529567719e-01, 7.115226387977600e-01, -5.186138153076172e-01, 4.093891084194183e-01,&
3965  -1.001899018883705e-01, -1.933344826102257e-02, 1.815729439258575e-01, -1.810713559389114e-01,&
3966  -5.504883527755737e-01, 7.005249857902527e-01, -1.967341639101505e-02, 1.448700390756130e-02,&
3967  3.791421651840210e-01, -3.687309324741364e-01, 6.238684058189392e-01, 2.549594640731812e-02,&
3968  6.611171960830688e-01, -2.348230034112930e-01, 4.087108075618744e-01, 1.835047304630280e-01,&
3969  2.745413780212402e-01, -5.477424860000610e-01, 4.227129369974136e-02, 1.370747834444046e-01,&
3970  -1.771535575389862e-01, 2.915630638599396e-01, 8.117929100990295e-02, -5.147354602813721e-01,&
3971  -7.195407748222351e-01, -2.950702905654907e-01, -8.272841572761536e-01, -8.926602080464363e-03,&
3972  6.488984823226929e-01, -7.542604207992554e-01, -1.718278229236603e-01, -4.908424615859985e-02,&
3973  -3.619753718376160e-01, -9.747832268476486e-02, -9.625122696161270e-02, -1.545960754156113e-01,&
3974  4.842050671577454e-01, -9.618758410215378e-02, 1.017526090145111e-01, -1.527849882841110e-01,&
3975  5.150741338729858e-01, -2.614658325910568e-02, -4.681808650493622e-01, 6.698484718799591e-02 &
3976  /), shape(hidden1synapse))
3977 
3978  outputsynapse = reshape((/ &
3979  -4.252142608165741e-01, -5.190939903259277e-01, 2.900628745555878e-01, -4.749988615512848e-01,&
3980  -2.432068884372711e-01, 2.475018054246902e-01, 1.508098654448986e-02, -1.032671928405762e-01,&
3981  -5.695398449897766e-01, -4.341589808464050e-01, 3.563072979450226e-01, -1.610363721847534e-01,&
3982  -1.529531776905060e-01, 3.572074323892593e-02, -1.639768481254578e-01, -2.103261351585388e-01,&
3983  -5.111085772514343e-01, -9.769214689731598e-02, -1.570120900869370e-01, -1.928524225950241e-01,&
3984  4.143640100955963e-01, -3.950143232941628e-02, -2.028328180313110e-01, -1.475265175104141e-01,&
3985  -2.296919003129005e-02, -3.979336936026812e-03, -3.908852040767670e-01, 4.192969501018524e-01,&
3986  2.397747188806534e-01, 4.962041378021240e-01, 4.480696618556976e-01, -2.336141020059586e-01,&
3987  3.938802778720856e-01, 2.352581322193146e-01, 1.772783696651459e-02, -5.289353057742119e-02,&
3988  -3.967223316431046e-02, -4.341553747653961e-01, -2.162312269210815e-01, 4.311326891183853e-02,&
3989  4.480128586292267e-01, 1.783114373683929e-01, 5.068565607070923e-01, -4.451447725296021e-01,&
3990  -5.096289515495300e-01, -4.807172119617462e-01, 1.144711822271347e-01, 3.887178003787994e-01,&
3991  -3.575057387351990e-01, -1.148879528045654e-01, -3.399987518787384e-02, -2.313354164361954e-01,&
3992  -7.217752188444138e-02, 3.657472431659698e-01, 3.738324940204620e-01, 4.177713990211487e-01,&
3993  -4.159389436244965e-01, -1.484509706497192e-01, 2.662932872772217e-01, -4.467738270759583e-01,&
3994  7.071519643068314e-02, 3.344006240367889e-01, -5.436876043677330e-02, 3.525221049785614e-01,&
3995  -2.395160868763924e-02, -3.141686320304871e-01, 3.852373957633972e-01, 4.932067096233368e-01,&
3996  -1.492380946874619e-01, 4.595996737480164e-01, 3.445216640830040e-02, -5.653984546661377e-01,&
3997  -4.437799155712128e-01, 1.460446715354919e-01, -4.742037057876587e-01, 1.456019878387451e-01,&
3998  3.867210447788239e-01, 4.871259629726410e-01, -4.954726397991180e-01, 1.770049333572388e-02,&
3999  2.028178423643112e-01, -3.220860958099365e-01, 2.971330881118774e-01, -1.783177554607391e-01,&
4000  -2.126741260290146e-01, -2.823735475540161e-01, 4.713099896907806e-01, 2.155631184577942e-01,&
4001  -3.713304102420807e-01, 2.199546098709106e-01, 2.943331003189087e-01, 4.534626007080078e-01,&
4002  3.414066731929779e-01, -1.535274535417557e-01, -1.036400645971298e-01, -4.483501911163330e-01,&
4003  8.723334968090057e-02, -1.368855964392424e-02, -5.010653138160706e-01, 4.472654759883881e-01,&
4004  1.106471717357635e-01, 5.139253139495850e-01, -2.296521663665771e-01, 4.545788764953613e-01,&
4005  1.664130948483944e-02, 2.438283525407314e-02, -1.943250745534897e-01, 4.952348470687866e-01,&
4006  3.839295804500580e-01, -3.456721901893616e-01, -1.650201976299286e-01, -3.892767727375031e-01,&
4007  -3.154349029064178e-01, 3.591218292713165e-01, -2.804268598556519e-01, -4.606449007987976e-01,&
4008  1.020256653428078e-01, 2.229744791984558e-01, -4.180959761142731e-01, -4.198006689548492e-01 &
4009  /), shape(outputsynapse))
4010 
4011  END SUBROUTINE breadboard5
4012 !
4013 !------------------------------------------------------------------------------
4014 !
4015  SUBROUTINE breadboard6(inputFile,hidden1Axon,hidden2Axon,&
4016  hidden1synapse,hidden2synapse,outputsynapse)
4017 
4018  implicit none
4019 
4020  real inputfile(2,7)
4021  real hidden1axon(7)
4022  real hidden2axon(4)
4023  real hidden1synapse(7,7)
4024  real hidden2synapse(7,4)
4025  real outputsynapse(4,3)
4026 
4027  inputfile = reshape((/ &
4028  1.353383421897888e+00, -4.533834457397461e-01,&
4029  2.269289046525955e-01, -1.588500849902630e-02,&
4030  1.868382692337036e-01, 6.490761637687683e-01,&
4031  4.038590788841248e-01, 3.776083141565323e-02,&
4032  2.430133521556854e-01, 3.004860281944275e-01,&
4033  1.935067623853683e-01, 4.185551702976227e-01,&
4034  1.951007992029190e-01, -4.725341200828552e-01 &
4035  /), shape(inputfile))
4036 
4037  hidden1axon = &
4038  (/ 7.384125608950853e-03, -2.202851057052612e+00, 2.003432661294937e-01, -2.467587143182755e-01,&
4039  5.973502993583679e-01, 3.834692537784576e-01, 2.687855064868927e-01/)
4040 
4041  hidden2axon = &
4042  (/ 3.643750846385956e-01, 2.449363768100739e-01, 4.754272103309631e-01, 7.550075054168701e-01/)
4043 
4044  hidden1synapse = reshape((/ &
4045  7.333400845527649e-01, 5.450296998023987e-01, -7.700046896934509e-01, 1.426693439483643e+00,&
4046  -1.024212338961661e-03, -6.459779292345047e-02, 1.028800487518311e+00, -2.116347402334213e-01,&
4047  3.591781139373779e+00, 2.435753583908081e+00, -6.687584519386292e-01, 1.201278567314148e+00,&
4048  -3.478864133358002e-01, 1.830960988998413e+00, -3.111673295497894e-01, -4.177703261375427e-01,&
4049  -3.920616805553436e-01, -5.040770769119263e-01, -5.354442000389099e-01, -1.534618530422449e-02,&
4050  -1.089364647865295e+00, -3.010036647319794e-01, 1.486289381980896e+00, 1.059559464454651e+00,&
4051  1.640596628189087e+00, 2.254628390073776e-01, 4.839954376220703e-01, 8.484285473823547e-01,&
4052  -6.926012784242630e-02, 4.926209524273872e-02, 2.834132313728333e-01, 3.028324842453003e-01,&
4053  2.161216735839844e-01, 7.251360416412354e-01, 2.851752638816833e-01, -5.653074979782104e-01,&
4054  3.640621304512024e-01, 1.341893225908279e-01, 7.511208057403564e-01, -1.088509336113930e-01,&
4055  1.044083759188652e-01, 6.529347300529480e-01, -6.885128021240234e-01, -1.003871187567711e-01,&
4056  9.337020665407181e-02, -4.425194561481476e-01, -3.668845295906067e-01, -2.661575675010681e-01,&
4057  -5.936880707740784e-01 &
4058  /), shape(hidden1synapse))
4059 
4060  hidden2synapse = reshape((/ &
4061  -5.461466908454895e-01, -1.490996479988098e+00, 7.721499800682068e-01, -3.842977285385132e-01,&
4062  1.134691461920738e-01, -7.171064615249634e-01, 4.990165829658508e-01, -4.233781099319458e-01,&
4063  5.502462983131409e-01, -1.000102013349533e-01, 1.481512188911438e+00, 1.637827455997467e-01,&
4064  5.879161506891251e-02, -3.256742060184479e-01, 4.237195849418640e-01, 1.471476674079895e+00,&
4065  -1.982609331607819e-01, 6.787789463996887e-01, 5.525223612785339e-01, 4.395257532596588e-01,&
4066  1.643348783254623e-01, 8.910947442054749e-01, 1.772162079811096e+00, -2.550726830959320e-01,&
4067  4.305597543716431e-01, 1.965346336364746e-01, -2.251276820898056e-01, -5.650298595428467e-01 &
4068  /), shape(hidden2synapse))
4069 
4070  outputsynapse = reshape((/ &
4071  4.605286195874214e-02, 1.636024713516235e-01, 7.045555710792542e-01, 4.994805455207825e-01,&
4072  5.167593955993652e-01, 2.924540340900421e-01, -1.490857079625130e-02, -1.826021969318390e-01,&
4073  3.571106493473053e-01, -3.790216147899628e-01, -6.031348705291748e-01, -4.664786159992218e-01 &
4074  /), shape(outputsynapse))
4075 
4076  END SUBROUTINE breadboard6
4077 !
4078 !------------------------------------------------------------------------------
4079 !
4080  SUBROUTINE breadboard7(inputFile,hidden1Axon,hidden2Axon,&
4081  hidden1synapse,hidden2synapse,outputsynapse)
4082 
4083  implicit none
4084 
4085  real inputfile(2,7)
4086  real hidden1axon(7)
4087  real hidden2axon(4)
4088  real hidden1synapse(7,7)
4089  real hidden2synapse(7,4)
4090  real outputsynapse(4,3)
4091 
4092  inputfile = reshape((/ &
4093  1.077844262123108e+00, -1.778443008661270e-01,&
4094  2.295625507831573e-01, 6.163756549358368e-02,&
4095  2.081165313720703e-01, 6.204994320869446e-01,&
4096  3.565062582492828e-01, -1.051693689078093e-02,&
4097  2.430133521556854e-01, 3.004860281944275e-01,&
4098  1.839550286531448e-01, 3.534696102142334e-01,&
4099  1.951007992029190e-01, -4.725341200828552e-01 &
4100  /), shape(inputfile))
4101 
4102  hidden1axon = &
4103  (/-4.191969335079193e-01, 1.229978561401367e+00, -2.403785735368729e-01, 5.233071446418762e-01,&
4104  8.062141537666321e-01, 1.000604867935181e+00, -1.015548110008240e-01/)
4105 
4106  hidden2axon = &
4107  (/-5.321261882781982e-01, -2.396449327468872e+00, -1.170158505439758e+00, -4.097367227077484e-01/)
4108 
4109  hidden1synapse = reshape((/ &
4110  1.341468811035156e+00, -4.215665817260742e+00, -1.636691570281982e+00, -2.792109727859497e+00,&
4111  -1.489341259002686e+00, 4.075187742710114e-01, -2.091729402542114e+00, -5.029736161231995e-01,&
4112  -4.151493072509766e+00, -1.452428579330444e+00, 2.398953676223755e+00, -8.748555183410645e-01,&
4113  1.340690374374390e+00, -2.277854681015015e+00, 6.057588458061218e-01, 1.353034019470215e+00,&
4114  -1.214678883552551e+00, -3.864320814609528e-01, 1.148570895195007e+00, 5.792776346206665e-01,&
4115  1.344245020300150e-02, -8.885311484336853e-01, -1.594583272933960e+00, 4.960928857326508e-01,&
4116  -1.118881464004517e+00, -2.252289772033691e+00, 6.328870654106140e-01, -1.946701169013977e+00,&
4117  -2.910976111888885e-01, 2.447998225688934e-01, 2.001658976078033e-01, -1.229660585522652e-02,&
4118  6.969845890998840e-01, -5.897524300962687e-03, -5.688555836677551e-01, 2.619750201702118e-01,&
4119  -4.162483692169189e+00, -1.468571424484253e+00, -3.118389844894409e+00, 6.947994828224182e-01,&
4120  -2.687734663486481e-01, -2.110401153564453e+00, 3.224660456180573e-02, 8.378994464874268e-01,&
4121  9.896742701530457e-01, -7.354493737220764e-01, 6.684727072715759e-01, 1.465887904167175e+00,&
4122  -3.726872503757477e-01 &
4123  /), shape(hidden1synapse))
4124 
4125  hidden2synapse = reshape((/ &
4126  -3.395457863807678e-01, -5.815528631210327e-01, 2.929831743240356e-01, -5.629656314849854e-01,&
4127  4.701104387640953e-02, -9.300172328948975e-01, -1.461120098829269e-01, -3.458845615386963e-01,&
4128  1.266251802444458e-01, 6.342335790395737e-02, 1.869771480560303e-01, -1.476681977510452e-01,&
4129  5.144428834319115e-02, -3.145390946883708e-04, 8.697064518928528e-01, 1.057970225811005e-01,&
4130  2.603019773960114e-01, 4.393529295921326e-01, -2.832717299461365e-01, 5.771816968917847e-01,&
4131  -3.896601796150208e-01, -7.260112762451172e-01, -7.957320213317871e-01, 6.776907294988632e-02,&
4132  -3.073690235614777e-01, -1.540119051933289e-01, -6.733091473579407e-01, 2.009786069393158e-01 &
4133  /), shape(hidden2synapse))
4134 
4135  outputsynapse = reshape((/ &
4136  3.156347572803497e-01, -8.236174583435059e-01, -9.946570396423340e-01, 4.212915897369385e-01,&
4137  -7.918102145195007e-01, -2.033229321241379e-01, -1.056663155555725e+00, -5.699685215950012e-01,&
4138  -9.666987657546997e-01, -5.505290031433105e-01, 8.724089711904526e-02, -9.536570906639099e-01 &
4139  /), shape(outputsynapse))
4140 
4141  END SUBROUTINE breadboard7
4142 !
4143 !------------------------------------------------------------------------------
4144 !
4145  SUBROUTINE breadboard8(inputFile,hidden1Axon,hidden2Axon,&
4146  hidden1synapse,hidden2synapse,outputsynapse)
4147 
4148  implicit none
4149 
4150  real inputfile(2,7)
4151  real hidden1axon(7)
4152  real hidden2axon(4)
4153  real hidden1synapse(7,7)
4154  real hidden2synapse(7,4)
4155  real outputsynapse(4,3)
4156 
4157  inputfile = reshape((/ &
4158  1.353383421897888e+00, -4.533834457397461e-01,&
4159  2.188449800014496e-01, 1.674167998135090e-02,&
4160  1.906577646732330e-01, 6.807435750961304e-01,&
4161  3.361344337463379e-01, 4.151264205574989e-02,&
4162  2.491349428892136e-01, 3.307266235351562e-01,&
4163  1.839550286531448e-01, 3.534696102142334e-01,&
4164  1.951007992029190e-01, -4.725341200828552e-01 &
4165  /), shape(inputfile))
4166 
4167  hidden1axon = &
4168  (/-3.274627029895782e-01, 2.668272238224745e-03, -3.019839525222778e-01, -4.557206928730011e-01,&
4169  -5.515558272600174e-02, 3.119016764685512e-04, 8.753398060798645e-02/)
4170 
4171  hidden2axon = &
4172  (/ 2.733168303966522e-01, -3.423235416412354e-01, 8.666662573814392e-01, -6.124708056449890e-01/)
4173 
4174  hidden1synapse = reshape((/ &
4175  2.732226848602295e-01, 1.847893238067627e+00, -1.084923520684242e-01, 1.385403037071228e+00,&
4176  2.885355055332184e-01, -3.135629594326019e-01, 1.057805895805359e+00, -5.868541821837425e-02,&
4177  3.278825521469116e+00, 4.641786217689514e-01, 4.461606740951538e-01, -1.952850073575974e-01,&
4178  -5.789646506309509e-01, 1.945697903633118e+00, -9.578172862529755e-02, 2.150904417037964e+00,&
4179  9.114052653312683e-01, 1.107189536094666e+00, 6.752110123634338e-01, 2.475811988115311e-01,&
4180  1.050705909729004e+00, 3.205673992633820e-01, 2.478840798139572e-01, -5.084273815155029e-01,&
4181  -2.407394796609879e-01, -1.702371835708618e-01, 1.456947028636932e-01, 3.221787512302399e-01,&
4182  -2.719256579875946e-01, -5.116361379623413e-01, 3.973563387989998e-02, -1.733802706003189e-01,&
4183  -1.649789661169052e-01, -4.471102654933929e-01, -4.071239829063416e-01, -1.492276042699814e-01,&
4184  -1.245773434638977e+00, -6.851593255996704e-01, -8.733592033386230e-01, -4.348643422126770e-01,&
4185  -3.520536422729492e-01, -9.930510520935059e-01, 1.956800930202007e-02, -9.781590104103088e-01,&
4186  -6.039583683013916e-01, -6.923800706863403e-01, -6.682770848274231e-01, 4.162513464689255e-02,&
4187  -1.004322052001953e+00 &
4188  /), shape(hidden1synapse))
4189 
4190  hidden2synapse = reshape((/ &
4191  -8.183520436286926e-01, -1.621446132659912e+00, -1.045793533325195e+00, -5.855653062462807e-02,&
4192  4.404523968696594e-01, 7.002395391464233e-01, 2.097517400979996e-01, -9.925779700279236e-02,&
4193  -8.263560533523560e-01, -1.043026208877563e+00, 4.524357020854950e-01, 2.231711596250534e-01,&
4194  8.736496567726135e-01, 8.797182440757751e-01, 6.963157653808594e-01, 2.816314399242401e-01,&
4195  1.525615751743317e-01, 1.936565339565277e-01, 1.900831162929535e-01, 1.180221140384674e-01,&
4196  1.027775928378105e-01, 9.149055480957031e-01, 1.129598617553711e+00, 6.131598353385925e-01,&
4197  2.547058761119843e-01, 2.556352131068707e-02, -3.627143800258636e-02, -6.722733378410339e-01 &
4198  /), shape(hidden2synapse))
4199 
4200  outputsynapse = reshape((/ &
4201  -5.266965627670288e-01, -1.973343640565872e-01, 1.362649053335190e-01, 9.479679167270660e-02,&
4202  2.987665235996246e-01, -3.116582632064819e-01, -1.842434853315353e-01, -4.986568093299866e-01,&
4203  6.261917948722839e-01, 5.454919338226318e-01, -3.484728187322617e-02, -4.687039256095886e-01 &
4204  /), shape(outputsynapse))
4205 
4206  END SUBROUTINE breadboard8
4207 !
4208 !------------------------------------------------------------------------------
4209 !
4210  SUBROUTINE breadboard9(inputFile,hidden1Axon,hidden2Axon,&
4211  hidden1synapse,hidden2synapse,outputsynapse)
4212 
4213  implicit none
4214 
4215  real inputfile(2,7)
4216  real hidden1axon(7)
4217  real hidden2axon(4)
4218  real hidden1synapse(7,7)
4219  real hidden2synapse(7,4)
4220  real outputsynapse(4,3)
4221 
4222  inputfile = reshape((/ &
4223  1.077844262123108e+00, -1.778443008661270e-01,&
4224  2.188449800014496e-01, 1.674167998135090e-02,&
4225  1.868382692337036e-01, 6.490761637687683e-01,&
4226  3.733665347099304e-01, 1.051026657223701e-01,&
4227  2.430133521556854e-01, 3.004860281944275e-01,&
4228  2.083092182874680e-01, 3.581876754760742e-01,&
4229  1.951007992029190e-01, -4.725341200828552e-01 &
4230  /), shape(inputfile))
4231 
4232  hidden1axon = &
4233  (/ 1.012814998626709e+00, -3.782782554626465e-01, -2.220184087753296e+00, -3.424299955368042e-01,&
4234  1.449530482292175e+00, -2.592789530754089e-01, -4.670010507106781e-01/)
4235 
4236  hidden2axon = &
4237  (/ 3.516010642051697e-01, 3.293374776840210e-01, -1.675553172826767e-01, 3.799068629741669e-01/)
4238 
4239  hidden1synapse = reshape((/ &
4240  1.390573829412460e-01, -3.110583126544952e-01, 1.105552077293396e+00, 4.394045472145081e-01,&
4241  4.795211851596832e-01, 1.969023197889328e-01, 5.574952811002731e-02, 1.690310984849930e-01,&
4242  2.208244323730469e+00, 2.111947536468506e+00, 3.239532709121704e-01, 7.690296173095703e-01,&
4243  1.264077782630920e+00, 1.672740578651428e+00, 1.320844173431396e+00, 7.965675592422485e-01,&
4244  -7.341063618659973e-01, 3.702043294906616e+00, 1.716022133827209e+00, -6.642882823944092e-01,&
4245  1.686427950859070e+00, -4.863217473030090e-01, 1.285641908645630e+00, 1.281449794769287e+00,&
4246  2.356275558471680e+00, -1.406845331192017e+00, 6.027717590332031e-01, 6.652191877365112e-01,&
4247  -9.871492385864258e-01, -5.513690948486328e+00, -2.750334143638611e-01, 1.229651212692261e+00,&
4248  -2.504641294479370e+00, -3.219850361347198e-01, -2.744197607040405e+00, -4.023179113864899e-01,&
4249  9.932321496307850e-03, -6.916724443435669e-01, -2.260914087295532e+00, 1.261568814516068e-01,&
4250  3.248662948608398e-01, 6.963043808937073e-01, 1.830800414085388e+00, -2.054267644882202e+00,&
4251  -9.595731496810913e-01, -8.711494207382202e-01, -1.330682396888733e+00, 2.109736204147339e+00,&
4252  -6.145163774490356e-01 &
4253  /), shape(hidden1synapse))
4254 
4255  hidden2synapse = reshape((/ &
4256  -3.299105465412140e-01, 4.235435724258423e-01, 9.191738963127136e-01, 6.795659661293030e-01,&
4257  -1.440919041633606e+00, 4.634908214211464e-02, -1.265781879425049e+00, 2.394487708806992e-01,&
4258  1.205053567886353e+00, 5.790516138076782e-01, 1.087130665779114e+00, -6.723164916038513e-01,&
4259  -1.834900081157684e-01, -4.767680168151855e-01, 8.402896672487259e-02, 1.035530328750610e+00,&
4260  1.644443035125732e+00, 4.317290484905243e-01, -1.714672803878784e+00, 5.225644707679749e-01,&
4261  -5.602287650108337e-01, 1.068559288978577e+00, -2.211284125223756e-03, -2.943626642227173e-01,&
4262  1.341261714696884e-01, 4.324447214603424e-01, -5.482236146926880e-01, -4.985276758670807e-01 &
4263  /), shape(hidden2synapse))
4264 
4265  outputsynapse = reshape((/ &
4266  3.726457059383392e-01, 7.749153375625610e-01, 4.159255921840668e-01, 5.234625935554504e-01,&
4267  -1.592817008495331e-01, 5.884559154510498e-01, -7.756121158599854e-01, 2.137655019760132e-01,&
4268  -6.172903776168823e-01, -4.417923986911774e-01, -4.576872885227203e-01, 4.440903961658478e-01 &
4269  /), shape(outputsynapse))
4270 
4271  END SUBROUTINE breadboard9
4272 !
4273 !------------------------------------------------------------------------------
4274 !
4275  SUBROUTINE breadboard10(inputFile,hidden1Axon,hidden2Axon,&
4276  hidden1synapse,hidden2synapse,outputsynapse)
4277 
4278  implicit none
4279 
4280  real inputfile(2,7)
4281  real hidden1axon(7)
4282  real hidden2axon(4)
4283  real hidden1synapse(7,7)
4284  real hidden2synapse(7,4)
4285  real outputsynapse(4,3)
4286 
4287  inputfile = reshape((/ &
4288  1.077844262123108e+00, -1.778443008661270e-01,&
4289  2.269289046525955e-01, -1.588500849902630e-02,&
4290  1.906577646732330e-01, 6.807435750961304e-01,&
4291  3.703703582286835e-01, -4.592590779066086e-02,&
4292  2.611723542213440e-01, 3.901915252208710e-01,&
4293  1.911842674016953e-01, 4.027296602725983e-01,&
4294  1.951007992029190e-01, -4.725341200828552e-01 &
4295  /), shape(inputfile))
4296 
4297  hidden1axon = &
4298  (/ 1.307985544204712e+00, -1.960705667734146e-01, -1.105142459273338e-01, -1.207442641258240e+00,&
4299  -1.665081620216370e+00, 1.251117825508118e+00, -7.307677268981934e-01/)
4300 
4301  hidden2axon = &
4302  (/ 2.186001092195511e-02, 3.369570672512054e-01, 1.165086925029755e-01, 2.747000660747290e-03/)
4303 
4304  hidden1synapse = reshape((/ &
4305  -3.375437259674072e-01, -3.020816326141357e+00, -1.435481071472168e+00, 1.473870635032654e+00,&
4306  -7.776365280151367e-01, 6.734371185302734e-01, -1.643768787384033e+00, -1.227448821067810e+00,&
4307  -7.365036606788635e-01, -4.473563134670258e-01, -5.696173906326294e-01, -2.562220990657806e-01,&
4308  8.557485342025757e-01, -8.057124614715576e-01, 4.266147911548615e-01, 2.171551227569580e+00,&
4309  3.776189982891083e-01, 5.574828386306763e-01, 3.814708292484283e-01, 2.591066062450409e-01,&
4310  1.959651827812195e+00, 1.003962755203247e-01, -1.228965446352959e-02, -3.882043361663818e-01,&
4311  -2.722288109362125e-02, -3.378733694553375e-01, -7.981095314025879e-01, 4.839731752872467e-01,&
4312  1.432798147201538e+00, 1.885666996240616e-01, -6.051751971244812e-01, 2.924412488937378e+00,&
4313  1.136252880096436e+00, 2.994727194309235e-01, 1.604383468627930e+00, -8.440219759941101e-01,&
4314  6.088087558746338e-01, -3.722844421863556e-01, 5.441566109657288e-01, 3.944540619850159e-01,&
4315  7.044004201889038e-01, 3.459328413009644e-01, 1.054268121719360e+00, -3.348083496093750e+00,&
4316  -7.199336886405945e-01, -1.489133596420288e+00, -4.090557992458344e-01, 8.203456401824951e-01,&
4317  -1.118073821067810e+00 &
4318  /), shape(hidden1synapse))
4319 
4320  hidden2synapse = reshape((/ &
4321  -6.871775984764099e-01, -1.148896694183350e+00, -2.102893590927124e-01, -5.890849828720093e-01,&
4322  5.899340510368347e-01, 7.098034024238586e-01, -1.422515869140625e+00, -1.206974506378174e+00,&
4323  4.104525446891785e-01, 3.567897081375122e-01, 2.746991515159607e-01, 1.193219542503357e+00,&
4324  3.167707324028015e-01, -1.222744822502136e+00, -9.918631613254547e-02, 4.355156719684601e-01,&
4325  2.938420772552490e-01, -1.012830615043640e+00, -1.290418803691864e-01, 7.479285597801208e-01,&
4326  -2.292920649051666e-01, -1.372484922409058e+00, -6.534293759614229e-03, 1.525195717811584e+00,&
4327  2.076585590839386e-01, 1.434590101242065e+00, 7.887706905603409e-02, -1.401232123374939e+00 &
4328  /), shape(hidden2synapse))
4329 
4330  outputsynapse = reshape((/ &
4331  6.101396083831787e-01, 3.122945129871368e-01, 3.869898915290833e-01, 4.438063502311707e-01,&
4332  5.161536335945129e-01, -2.700618803501129e-01, -3.105166740715504e-02, -5.569267272949219e-01,&
4333  -5.549081563949585e-01, -3.867979049682617e-01, 1.623111665248871e-01, -6.052750945091248e-01 &
4334  /), shape(outputsynapse))
4335 
4336  END SUBROUTINE breadboard10
4337 !
4338 !-------------------------------------------------------------------------------------
4339 !
4373 
4374  SUBROUTINE calslr_uutah(SLR)
4375 
4376  use vrbls3d, only: zint,zmid,pmid,t,q,uh,vh
4377  use masks, only: lmh,htm
4378  use ctlblk_mod, only: ista,iend,jsta,jend,ista_2l,iend_2u,jsta_2l,jend_2u,&
4379  lm,spval
4380 
4381  implicit none
4382 
4383  real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(out) :: slr !slr=snod/weasd=1000./sndens
4384 
4385  integer, parameter :: nfl=3
4386  real, parameter :: htfl(nfl)=(/ 500., 1000., 2000. /)
4387  real,dimension(ISTA:IEND,JSTA:JEND,NFL) :: tfd,ufd,vfd
4388 
4389  real lhl(nfl),dzabh(nfl),swnd(nfl)
4390  real htsfc,htabh,dz,rdz,delt,delu,delv
4391 
4392  real, parameter :: m1 = -0.174848
4393  real, parameter :: m2 = -0.52644
4394  real, parameter :: m3 = 0.034911
4395  real, parameter :: m4 = -0.270473
4396  real, parameter :: m5 = 0.028299
4397  real, parameter :: m6 = 0.096273
4398  real, parameter :: b =118.35844
4399 
4400  integer,dimension(ISTA:IEND,JSTA:JEND) :: karr
4401  integer,dimension(ISTA:IEND,JSTA:JEND) :: twet05
4402  real,dimension(ISTA:IEND,JSTA:JEND) :: zwet
4403 
4404  REAL, ALLOCATABLE :: twet(:,:,:)
4405 
4406  integer i,j,l,llmh,lmhk,ifd
4407 !
4408 !***************************************************************************
4409 !
4410  ALLOCATE(twet(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
4411 
4412  DO ifd = 1,nfl
4413 !$omp parallel do private(i,j)
4414  DO j=jsta,jend
4415  DO i=ista,iend
4416  tfd(i,j,ifd) = spval
4417  ufd(i,j,ifd) = spval
4418  vfd(i,j,ifd) = spval
4419  ENDDO
4420  ENDDO
4421  ENDDO
4422 
4423 ! LOCATE VERTICAL INDICES OF T,U,V, LEVEL JUST
4424 ! ABOVE EACH FD LEVEL.
4425 
4426  DO j=jsta,jend
4427  DO i=ista,iend
4428  IF(zint(i,j,lm+1)<spval) THEN
4429  htsfc = zint(i,j,lm+1)
4430  llmh = nint(lmh(i,j))
4431  ifd = 1
4432  DO l = llmh,1,-1
4433  htabh = zmid(i,j,l)-htsfc
4434  IF(htabh>htfl(ifd)) THEN
4435  lhl(ifd) = l
4436  dzabh(ifd) = htabh-htfl(ifd)
4437  ifd = ifd + 1
4438  ENDIF
4439  IF(ifd > nfl) exit
4440  ENDDO
4441 
4442 ! COMPUTE T, U, V AT FD LEVELS.
4443 
4444  DO ifd = 1,nfl
4445  l = lhl(ifd)
4446  IF (l<lm .AND. t(i,j,l)<spval .AND. uh(i,j,l)<spval .AND. vh(i,j,l)<spval) THEN
4447  dz = zmid(i,j,l)-zmid(i,j,l+1)
4448  rdz = 1./dz
4449  delt = t(i,j,l)-t(i,j,l+1)
4450  tfd(i,j,ifd) = t(i,j,l) - delt*rdz*dzabh(ifd)
4451  delu = uh(i,j,l)-uh(i,j,l+1)
4452  delv = vh(i,j,l)-vh(i,j,l+1)
4453  ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabh(ifd)
4454  vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabh(ifd)
4455  ELSE
4456  tfd(i,j,ifd) = t(i,j,l)
4457  ufd(i,j,ifd) = uh(i,j,l)
4458  vfd(i,j,ifd) = vh(i,j,l)
4459  ENDIF
4460  ENDDO
4461  ENDIF !IF(ZINT(I,J,LM+1)<SPVAL)
4462  ENDDO !I loop
4463  ENDDO !J loop
4464 
4465 ! COMPUTE SLR
4466 
4467  slr = spval
4468 
4469 !$omp parallel do private(i,j)
4470  DO j=jsta,jend
4471  DO i=ista,iend
4472  IF(tfd(i,j,1)<spval .AND. ufd(i,j,1)<spval .AND. vfd(i,j,1)<spval) THEN
4473  swnd(1)=sqrt(ufd(i,j,1)*ufd(i,j,1)+vfd(i,j,1)*vfd(i,j,1))
4474  swnd(2)=sqrt(ufd(i,j,2)*ufd(i,j,2)+vfd(i,j,2)*vfd(i,j,2))
4475  swnd(3)=sqrt(ufd(i,j,3)*ufd(i,j,3)+vfd(i,j,3)*vfd(i,j,3))
4476  slr(i,j) = m1*swnd(2)+m2*tfd(i,j,3)+m3*swnd(3)+m4*swnd(1)+m5*tfd(i,j,2)+m6*tfd(i,j,1)+b
4477  slr(i,j) = max(slr(i,j),3.)
4478  ENDIF
4479  ENDDO
4480  ENDDO
4481 
4482 ! COMPUTE WETBULB TEMPERATURE AND SEARCH FOR TWET > 0.5C
4483 
4484  karr = 1
4485  CALL wetbulb(t,q,pmid,htm,karr,twet)
4486 
4487 !$omp parallel do private(i,j)
4488  DO j=jsta,jend
4489  DO i=ista,iend
4490  zwet(i,j)=zmid(i,j,lm)
4491  twet05(i,j)=-1
4492  ENDDO
4493  ENDDO
4494 
4495  DO l=lm,1,-1
4496 !$omp parallel do private(i,j)
4497  DO j=jsta,jend
4498  DO i=ista,iend
4499  IF(twet05(i,j) < 0) THEN
4500  IF(twet(i,j,l) <= 273.15+0.5) THEN
4501  zwet(i,j)=zmid(i,j,l)
4502  twet05(i,j)=1
4503  ENDIF
4504  ENDIF
4505  ENDDO
4506  ENDDO
4507  ENDDO
4508 
4509 !$omp parallel do private(i,j,HTABH)
4510  DO j=jsta,jend
4511  DO i=ista,iend
4512  IF(twet05(i,j) > 0 .AND. slr(i,j)<spval) THEN
4513  htabh=zwet(i,j)-zint(i,j,lm+1)
4514  IF(htabh<0.) htabh=0.
4515  slr(i,j)=slr(i,j)*(1.-htabh/200.)
4516  IF(slr(i,j)<0.) slr(i,j)=0.
4517  ENDIF
4518  ENDDO
4519  ENDDO
4520 
4521  DEALLOCATE (twet)
4522 
4523  END SUBROUTINE calslr_uutah
4524 !
4525 !-------------------------------------------------------------------------------------
4526 !
4527  end module upp_physics
4528 
upp_physics::calcape2
subroutine, public calcape2(ITYPE, DPBND, P1D, T1D, Q1D, L1D, CAPE, CINS, LFC, ESRHL, ESRHH, DCAPE, DGLD, ESP)
calcape2() computes CAPE and CINS.
Definition: UPP_PHYSICS.f:1040
ctlblk_mod
Definition: CTLBLK.f:1
upp_math::dvdxdudy
subroutine, public dvdxdudy(uwnd, vwnd)
dvdxdudy() computes dudy, dvdx, uwnd
Definition: UPP_MATH.f:54
upp_physics::calgradps
subroutine, public calgradps(PS, PSX, PSY)
CALGRADPS computes gardients of a scalar field PS or LNPS.
Definition: UPP_PHYSICS.f:2462
upp_physics::calslr_roebber
subroutine, public calslr_roebber(tprs, rhprs, slr)
calslr_roebber() computes snow solid-liquid-ratio slr using the Roebber algorithm.
Definition: UPP_PHYSICS.f:2705
upp_physics::calslr_uutah
subroutine, public calslr_uutah(SLR)
calslr_uutah() computes snow solid-liquid-ratio slr using the Steenburgh algorithm.
Definition: UPP_PHYSICS.f:4374
upp_physics::calrh_gsd
subroutine, public calrh_gsd(P1, T1, Q1, RHB)
CALRH_GSD() Compute RH with the NOAA GSL (formerly NOAA GSD) algorithm used for RUC and Rapid Refresh...
Definition: UPP_PHYSICS.f:270
upp_physics::calrh_pw
subroutine, public calrh_pw(RHPW)
CALRH_PW() algorithm used at GSL for RUC and Rapid Refresh.
Definition: UPP_PHYSICS.f:312
masks
Definition: MASKS_mod.f:1
upp_physics::calrh_gfs
subroutine, public calrh_gfs(P1, T1, Q1, RH)
calrh_gfs() computes relative humidity.
Definition: UPP_PHYSICS.f:197
upp_physics::calrh_nam
subroutine, public calrh_nam(P1, T1, Q1, RH)
calrh_nam() computes relative humidity.
Definition: UPP_PHYSICS.f:118
params_mod
Definition: params.F:1
grib2_module
Definition: grib2_module.f:1
upp_physics::calvor
subroutine, public calvor(UWND, VWND, ABSV)
CALVOR() computes absolute vorticity.
Definition: UPP_PHYSICS.f:1744
upp_physics::caldiv
subroutine, public caldiv(UWND, VWND, DIV)
CALDIV computes divergence.
Definition: UPP_PHYSICS.f:2175
upp_physics::calrh
subroutine, public calrh(P1, T1, Q1, RH)
CALRH() computes relative humidity.
Definition: UPP_PHYSICS.f:72
upp_math
Definition: UPP_MATH.f:19
upp_physics::tvirtual
elemental real function, public tvirtual(T, Q)
Definition: UPP_PHYSICS.f:1702
upp_physics::fpvsnew
elemental real function, public fpvsnew(t)
Definition: UPP_PHYSICS.f:378
upp_physics::calcape
subroutine, public calcape(ITYPE, DPBND, P1D, T1D, Q1D, L1D, CAPE, CINS, PPARC, ZEQL, THUND)
calcape() computes CAPE and CINS.
Definition: UPP_PHYSICS.f:562
upp_physics
Definition: UPP_PHYSICS.f:40
lookup_mod
Definition: LOOKUP.f:1