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