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