diff --git a/CALHEL2_8f.html b/CALHEL2_8f.html index b7e81f992..f98ee9f30 100644 --- a/CALHEL2_8f.html +++ b/CALHEL2_8f.html @@ -3,7 +3,7 @@ - + UPP: CALHEL2.f File Reference @@ -30,7 +30,7 @@
UPP -  V11.0.0 +  11.0.0
@@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
@@ -116,21 +116,21 @@ - - - + + +

Functions/Subroutines

subroutine CALHEL2 (LLOW, LUPP, DEPTH, UST, VST, HELI, CANGLE)
 This routine computes estimated storm motion and storm-relative environmental helicity. More...
 
subroutine calhel2 (LLOW, LUPP, DEPTH, UST, VST, HELI, CANGLE)
 Subroutine that computes storm relative helicity. More...
 

Detailed Description

Subroutine that computes storm relative helicity.

Definition in file CALHEL2.f.

Function/Subroutine Documentation

- +
- + @@ -179,58 +179,23 @@
subroutine CALHEL2 subroutine calhel2 ( integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in)  LLOW,
-

This routine computes estimated storm motion and storm-relative environmental helicity.

-

(Davies-Jones et al 1990) the algorithm processd as follows.

-

The storm motion computation no longer employs the Davies and Johns (1993) method which defined storm motion as 30 degress to the right of the 0-6 km mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees to the right for speeds greater than 15 m/s. Instead, we now use the dynamic method (Bunkers et al. 1988) which has been found to do better in cases with 'non-classic' hodographs (such as Northwest-flow events) and do as well or better than the old method in more classic situations.

+

Subroutine that computes storm relative helicity.

Parameters
- + - - - -
[in]LLOWLower bound CAPE>=100 and CINS>=-250.
[in]LUPPUpper bound CAPE< 100 or CINS< -250; allows one to distinguish 0-3 km and 0-1 km values.
[in]DPTHDepth in meters over whcih helicity should be computed; allows one to distinguish 0-3 km and 0-1 km values.
[in]DEPTHDepth in meters over whcih helicity should be computed; allows one to distinguish 0-3 km and 0-1 km values.
[out]USTEstimated U Component (m/s) Of Storm motion.
[out]VSTEstimated V Component (m/s) Of Storm motion.
[out]HELIStorm-relative heliciry (m**2/s**2).
[out]CANGLECritical angle.
[out]USHR1U Component (m/s) Of 0-1 km shear.
[out]VSHR1V Component (m/s) Of 0-1 km shear.
[out]USHR6U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear.
[out]VSHR6V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear.
-

Program history log:

- - - - - - - - - - - - - - - - - - - - - - - - - - - -
Date Programmer Comments
1994-08-22 Michael Baldwin Initial
1997-03-27 Michael Baldwin Speed up code
1998-06-15 T Black Conversion from 1-D to 2-D
2000-01-04 Jim Tuccillo MPI Version
2000-01-10 G Manikin Changed to Bunkers method
2002-05-22 G Manikin Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths
2003-03-25 G Manikin Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method
2004-04-16 M Pyle Minimal modifications but put into NMM WRFPOST code
2005-02-25 H Chuang Add computation for ARW A grid
2005-07-07 Binbin Zhou Add RSM for A grid
2019-09-03 J Meng Modified to compute effective helicity and critical angle
2021-09-02 Bo Cui Decompose UPP in X direction
-
Author
Michael Baldwin W/NP2
-
Date
1994-08-22
-

Definition at line 45 of file CALHEL2.f.

+

Definition at line 57 of file CALHEL2.f.

+ +

Referenced by miscln().

@@ -242,7 +207,7 @@

Program history log:

  • sorc
  • ncep_post.fd
  • CALHEL2.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5
    diff --git a/CALHEL2_8f.js b/CALHEL2_8f.js index 42e1941eb..08d42a815 100644 --- a/CALHEL2_8f.js +++ b/CALHEL2_8f.js @@ -1,4 +1,4 @@ var CALHEL2_8f = [ - [ "CALHEL2", "CALHEL2_8f.html#af4c008bab32f1815e5a3aabcc7a93176", null ] + [ "calhel2", "CALHEL2_8f.html#a7d05f13ed56ac5ef73f92a84782554c1", null ] ]; \ No newline at end of file diff --git a/CALHEL2_8f_source.html b/CALHEL2_8f_source.html index 8df13beae..e77483438 100644 --- a/CALHEL2_8f_source.html +++ b/CALHEL2_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALHEL2.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -108,437 +108,441 @@
    Go to the documentation of this file.
    1 
    3 !
    -
    45  SUBROUTINE calhel2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE)
    -
    46 
    -
    47 !
    -
    48  use vrbls3d, only: zmid, uh, vh, u, v, zint
    -
    49  use vrbls2d, only: fis, u10, v10
    -
    50  use masks, only: lmv
    -
    51  use params_mod, only: g
    -
    52  use lookup_mod, only: itb,jtb,itbq,jtbq
    -
    53  use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, &
    -
    54  lm, im, jm, me, spval, &
    -
    55  ista, iend, ista_m, iend_m, ista_2l, iend_2u
    -
    56  use gridspec_mod, only: gridtype
    -
    57 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    58  implicit none
    -
    59 !
    -
    60  real,PARAMETER :: p150=15000.0,p300=30000.0,s15=15.0
    -
    61  real,PARAMETER :: d3000=3000.0,pi6=0.5235987756,pi9=0.34906585
    -
    62  real,PARAMETER :: d5500=5500.0,d6000=6000.0,d7000=7000.0
    -
    63  real,PARAMETER :: d500=500.0
    -
    64 ! CRA
    -
    65  real,PARAMETER :: d1000=1000.0
    -
    66  real,PARAMETER :: d1500=1500.0
    -
    67 ! CRA
    -
    68  REAL, PARAMETER :: pi = 3.1415927
    -
    69 
    -
    70 !
    -
    71 ! DECLARE VARIABLES
    -
    72 !
    -
    73  integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: llow, lupp
    -
    74  real,intent(in) :: depth(2)
    -
    75  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: ust,vst
    -
    76  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,2),intent(out) :: heli
    -
    77  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: cangle
    -
    78 !
    -
    79  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: htsfc, ust6, vst6, ust5, vst5, &
    -
    80  ust1, vst1, ushr1, vshr1, &
    -
    81  ushr6, vshr6, u1, v1, u2, v2, &
    -
    82  hgt1, hgt2, umean, vmean
    -
    83  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: ushr05,vshr05
    -
    84 
    -
    85 ! REAL HTSFC(IM,JM)
    -
    86 !
    -
    87 ! REAL UST6(IM,JM),VST6(IM,JM)
    -
    88 ! REAL UST5(IM,JM),VST5(IM,JM)
    -
    89 ! REAL UST1(IM,JM),VST1(IM,JM)
    -
    90 ! CRA
    -
    91 ! REAL USHR1(IM,JM),VSHR1(IM,JM),USHR6(IM,JM),VSHR6(IM,JM)
    -
    92 ! REAL U1(IM,JM),V1(IM,JM),U2(IM,JM),V2(IM,JM)
    -
    93 ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM)
    -
    94 ! CRA
    -
    95 
    -
    96  integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: count6, count5, count1, l1, l2
    -
    97 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM)
    -
    98 ! CRA
    -
    99 ! INTEGER L1(IM,JM),L2(IM,JM)
    -
    100 ! CRA
    -
    101 
    -
    102  INTEGER ive(jm),ivw(jm)
    -
    103  integer i,j,iw,ie,js,jn,jvn,jvs,l,n,lv
    -
    104  integer istart,istop,jstart,jstop
    -
    105  real z2,dzabv,umean5,vmean5,umean1,vmean1,umean6,vmean6, &
    -
    106  denom,z1,z3,dz,dz1,dz2,du1,du2,dv1,dv2
    -
    107 !
    -
    108 !****************************************************************
    -
    109 ! START CALHEL HERE
    -
    110 !
    -
    111 ! INITIALIZE ARRAYS.
    -
    112 !
    -
    113 !$omp parallel do private(i,j)
    -
    114  DO j=jsta,jend
    -
    115  DO i=ista,iend
    -
    116  ust(i,j) = 0.0
    -
    117  vst(i,j) = 0.0
    -
    118  heli(i,j,1) = 0.0
    -
    119  heli(i,j,2) = 0.0
    -
    120  cangle(i,j) = 0.0
    -
    121  ust1(i,j) = 0.0
    -
    122  vst1(i,j) = 0.0
    -
    123  ust5(i,j) = 0.0
    -
    124  vst5(i,j) = 0.0
    -
    125  ust6(i,j) = 0.0
    -
    126  vst6(i,j) = 0.0
    -
    127  count6(i,j) = 0
    -
    128  count5(i,j) = 0
    -
    129  count1(i,j) = 0
    -
    130 ! CRA
    -
    131  ushr05(i,j) = 0.0
    -
    132  vshr05(i,j) = 0.0
    -
    133  ushr1(i,j) = 0.0
    -
    134  vshr1(i,j) = 0.0
    -
    135  ushr6(i,j) = 0.0
    -
    136  vshr6(i,j) = 0.0
    -
    137  u1(i,j) = 0.0
    -
    138  u2(i,j) = 0.0
    -
    139  v1(i,j) = 0.0
    -
    140  v2(i,j) = 0.0
    -
    141  umean(i,j) = 0.0
    -
    142  vmean(i,j) = 0.0
    -
    143  hgt1(i,j) = 0.0
    -
    144  hgt2(i,j) = 0.0
    -
    145  l1(i,j) = 0
    -
    146  l2(i,j) = 0
    -
    147 ! CRA
    -
    148 
    -
    149  ENDDO
    -
    150  ENDDO
    -
    151  IF(gridtype == 'E')THEN
    -
    152  jvn = 1
    -
    153  jvs = -1
    -
    154  do j=jsta,jend
    -
    155  ive(j) = mod(j,2)
    -
    156  ivw(j) = ive(j)-1
    -
    157  enddo
    -
    158  istart = ista_m
    -
    159  istop = iend_m
    -
    160  jstart = jsta_m
    -
    161  jstop = jend_m
    -
    162  ELSE IF(gridtype == 'B')THEN
    -
    163  jvn = 1
    -
    164  jvs = 0
    -
    165  do j=jsta,jend
    -
    166  ive(j)=1
    -
    167  ivw(j)=0
    -
    168  enddo
    -
    169  istart = ista_m
    -
    170  istop = iend_m
    -
    171  jstart = jsta_m
    -
    172  jstop = jend_m
    -
    173  ELSE
    -
    174  jvn = 0
    -
    175  jvs = 0
    -
    176  do j=jsta,jend
    -
    177  ive(j) = 0
    -
    178  ivw(j) = 0
    -
    179  enddo
    -
    180  istart = ista
    -
    181  istop = iend
    -
    182  jstart = jsta
    -
    183  jstop = jend
    -
    184  END IF
    -
    185 !
    -
    186 ! LOOP OVER HORIZONTAL GRID.
    -
    187 !
    -
    188 ! CALL EXCH(RES(1,jsta_2l)
    -
    189 ! CALL EXCH(PD()
    -
    190 
    -
    191 ! DO L = 1,LP1
    -
    192 ! CALL EXCH(ZINT(1,jsta_2l,L))
    -
    193 ! END DO
    -
    194 !
    -
    195 !!$omp parallel do private(htsfc,ie,iw)
    -
    196  IF(gridtype /= 'A') CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
    -
    197  DO l = 1,lm
    -
    198  IF(gridtype /= 'A') CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
    -
    199  DO j=jstart,jstop
    -
    200  DO i=istart,istop
    -
    201  ie = i+ive(j)
    -
    202  iw = i+ivw(j)
    -
    203  jn = j+jvn
    -
    204  js = j+jvs
    -
    205 !mp PDSLVK=(PD(IW,J)*RES(IW,J)+PD(IE,J)*RES(IE,J)+
    -
    206 !mp 1 PD(I,J+1)*RES(I,J+1)+PD(I,J-1)*RES(I,J-1))*0.25
    -
    207 !mp PSFCK=AETA(LMV(I,J))*PDSLVK+PT
    -
    208  IF (gridtype=='B')THEN
    -
    209  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))
    -
    210 !
    -
    211 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    -
    212 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    -
    213 !
    -
    214  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    -
    215  ELSE
    -
    216  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))
    -
    217 !
    -
    218 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    -
    219 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    -
    220 !
    -
    221  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    -
    222  END IF
    -
    223  dzabv = z2-htsfc(i,j)
    -
    224 
    -
    225  lv = nint(lmv(i,j))
    -
    226  IF (dzabv <= d6000 .AND. l <= lv) THEN
    -
    227  ust6(i,j) = ust6(i,j) + uh(i,j,l)
    -
    228  vst6(i,j) = vst6(i,j) + vh(i,j,l)
    -
    229  count6(i,j) = count6(i,j) + 1
    -
    230  ENDIF
    -
    231 
    -
    232  IF (dzabv < d6000 .AND. dzabv >= d5500 .AND. l <= lv) THEN
    -
    233  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    -
    234  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    -
    235  count5(i,j) = count5(i,j) + 1
    -
    236  ENDIF
    -
    237 
    -
    238  IF (dzabv < d500 .AND. l <= lv) THEN
    -
    239  ust1(i,j) = ust1(i,j) + uh(i,j,l)
    -
    240  vst1(i,j) = vst1(i,j) + vh(i,j,l)
    -
    241  count1(i,j) = count1(i,j) + 1
    +
    45 !-----------------------------------------------------------------------
    +
    56 !-----------------------------------------------------------------------
    +
    57  SUBROUTINE calhel2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE)
    +
    58 
    +
    59 !
    +
    60  use vrbls3d, only: zmid, uh, vh, u, v, zint
    +
    61  use vrbls2d, only: fis, u10, v10
    +
    62  use masks, only: lmv
    +
    63  use params_mod, only: g
    +
    64  use lookup_mod, only: itb,jtb,itbq,jtbq
    +
    65  use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, &
    +
    66  lm, im, jm, me, spval, &
    +
    67  ista, iend, ista_m, iend_m, ista_2l, iend_2u
    +
    68  use gridspec_mod, only: gridtype
    +
    69 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    70  implicit none
    +
    71 !
    +
    72  real,PARAMETER :: p150=15000.0,p300=30000.0,s15=15.0
    +
    73  real,PARAMETER :: d3000=3000.0,pi6=0.5235987756,pi9=0.34906585
    +
    74  real,PARAMETER :: d5500=5500.0,d6000=6000.0,d7000=7000.0
    +
    75  real,PARAMETER :: d500=500.0
    +
    76 ! CRA
    +
    77  real,PARAMETER :: d1000=1000.0
    +
    78  real,PARAMETER :: d1500=1500.0
    +
    79 ! CRA
    +
    80  REAL, PARAMETER :: pi = 3.1415927
    +
    81 
    +
    82 !
    +
    83 ! DECLARE VARIABLES
    +
    84 !
    +
    85  integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: llow, lupp
    +
    86  real,intent(in) :: depth(2)
    +
    87  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: ust,vst
    +
    88  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,2),intent(out) :: heli
    +
    89  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: cangle
    +
    90 !
    +
    91  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: htsfc, ust6, vst6, ust5, vst5, &
    +
    92  ust1, vst1, ushr1, vshr1, &
    +
    93  ushr6, vshr6, u1, v1, u2, v2, &
    +
    94  hgt1, hgt2, umean, vmean
    +
    95  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: ushr05,vshr05
    +
    96 
    +
    97 ! REAL HTSFC(IM,JM)
    +
    98 !
    +
    99 ! REAL UST6(IM,JM),VST6(IM,JM)
    +
    100 ! REAL UST5(IM,JM),VST5(IM,JM)
    +
    101 ! REAL UST1(IM,JM),VST1(IM,JM)
    +
    102 ! CRA
    +
    103 ! REAL USHR1(IM,JM),VSHR1(IM,JM),USHR6(IM,JM),VSHR6(IM,JM)
    +
    104 ! REAL U1(IM,JM),V1(IM,JM),U2(IM,JM),V2(IM,JM)
    +
    105 ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM)
    +
    106 ! CRA
    +
    107 
    +
    108  integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: count6, count5, count1, l1, l2
    +
    109 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM)
    +
    110 ! CRA
    +
    111 ! INTEGER L1(IM,JM),L2(IM,JM)
    +
    112 ! CRA
    +
    113 
    +
    114  INTEGER ive(jm),ivw(jm)
    +
    115  integer i,j,iw,ie,js,jn,jvn,jvs,l,n,lv
    +
    116  integer istart,istop,jstart,jstop
    +
    117  real z2,dzabv,umean5,vmean5,umean1,vmean1,umean6,vmean6, &
    +
    118  denom,z1,z3,dz,dz1,dz2,du1,du2,dv1,dv2
    +
    119 !
    +
    120 !****************************************************************
    +
    121 ! START CALHEL HERE
    +
    122 !
    +
    123 ! INITIALIZE ARRAYS.
    +
    124 !
    +
    125 !$omp parallel do private(i,j)
    +
    126  DO j=jsta,jend
    +
    127  DO i=ista,iend
    +
    128  ust(i,j) = 0.0
    +
    129  vst(i,j) = 0.0
    +
    130  heli(i,j,1) = 0.0
    +
    131  heli(i,j,2) = 0.0
    +
    132  cangle(i,j) = 0.0
    +
    133  ust1(i,j) = 0.0
    +
    134  vst1(i,j) = 0.0
    +
    135  ust5(i,j) = 0.0
    +
    136  vst5(i,j) = 0.0
    +
    137  ust6(i,j) = 0.0
    +
    138  vst6(i,j) = 0.0
    +
    139  count6(i,j) = 0
    +
    140  count5(i,j) = 0
    +
    141  count1(i,j) = 0
    +
    142 ! CRA
    +
    143  ushr05(i,j) = 0.0
    +
    144  vshr05(i,j) = 0.0
    +
    145  ushr1(i,j) = 0.0
    +
    146  vshr1(i,j) = 0.0
    +
    147  ushr6(i,j) = 0.0
    +
    148  vshr6(i,j) = 0.0
    +
    149  u1(i,j) = 0.0
    +
    150  u2(i,j) = 0.0
    +
    151  v1(i,j) = 0.0
    +
    152  v2(i,j) = 0.0
    +
    153  umean(i,j) = 0.0
    +
    154  vmean(i,j) = 0.0
    +
    155  hgt1(i,j) = 0.0
    +
    156  hgt2(i,j) = 0.0
    +
    157  l1(i,j) = 0
    +
    158  l2(i,j) = 0
    +
    159 ! CRA
    +
    160 
    +
    161  ENDDO
    +
    162  ENDDO
    +
    163  IF(gridtype == 'E')THEN
    +
    164  jvn = 1
    +
    165  jvs = -1
    +
    166  do j=jsta,jend
    +
    167  ive(j) = mod(j,2)
    +
    168  ivw(j) = ive(j)-1
    +
    169  enddo
    +
    170  istart = ista_m
    +
    171  istop = iend_m
    +
    172  jstart = jsta_m
    +
    173  jstop = jend_m
    +
    174  ELSE IF(gridtype == 'B')THEN
    +
    175  jvn = 1
    +
    176  jvs = 0
    +
    177  do j=jsta,jend
    +
    178  ive(j)=1
    +
    179  ivw(j)=0
    +
    180  enddo
    +
    181  istart = ista_m
    +
    182  istop = iend_m
    +
    183  jstart = jsta_m
    +
    184  jstop = jend_m
    +
    185  ELSE
    +
    186  jvn = 0
    +
    187  jvs = 0
    +
    188  do j=jsta,jend
    +
    189  ive(j) = 0
    +
    190  ivw(j) = 0
    +
    191  enddo
    +
    192  istart = ista
    +
    193  istop = iend
    +
    194  jstart = jsta
    +
    195  jstop = jend
    +
    196  END IF
    +
    197 !
    +
    198 ! LOOP OVER HORIZONTAL GRID.
    +
    199 !
    +
    200 ! CALL EXCH(RES(1,jsta_2l)
    +
    201 ! CALL EXCH(PD()
    +
    202 
    +
    203 ! DO L = 1,LP1
    +
    204 ! CALL EXCH(ZINT(1,jsta_2l,L))
    +
    205 ! END DO
    +
    206 !
    +
    207 !!$omp parallel do private(htsfc,ie,iw)
    +
    208  IF(gridtype /= 'A') CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
    +
    209  DO l = 1,lm
    +
    210  IF(gridtype /= 'A') CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
    +
    211  DO j=jstart,jstop
    +
    212  DO i=istart,istop
    +
    213  ie = i+ive(j)
    +
    214  iw = i+ivw(j)
    +
    215  jn = j+jvn
    +
    216  js = j+jvs
    +
    217 !mp PDSLVK=(PD(IW,J)*RES(IW,J)+PD(IE,J)*RES(IE,J)+
    +
    218 !mp 1 PD(I,J+1)*RES(I,J+1)+PD(I,J-1)*RES(I,J-1))*0.25
    +
    219 !mp PSFCK=AETA(LMV(I,J))*PDSLVK+PT
    +
    220  IF (gridtype=='B')THEN
    +
    221  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))
    +
    222 !
    +
    223 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    +
    224 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    +
    225 !
    +
    226  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    +
    227  ELSE
    +
    228  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))
    +
    229 !
    +
    230 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    +
    231 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    +
    232 !
    +
    233  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    +
    234  END IF
    +
    235  dzabv = z2-htsfc(i,j)
    +
    236 
    +
    237  lv = nint(lmv(i,j))
    +
    238  IF (dzabv <= d6000 .AND. l <= lv) THEN
    +
    239  ust6(i,j) = ust6(i,j) + uh(i,j,l)
    +
    240  vst6(i,j) = vst6(i,j) + vh(i,j,l)
    +
    241  count6(i,j) = count6(i,j) + 1
    242  ENDIF
    -
    243 ! CRA
    -
    244  IF (dzabv >= d1000 .AND. dzabv <= d1500 .AND. l <= lv) THEN
    -
    245  u2(i,j) = u(i,j,l)
    -
    246  v2(i,j) = v(i,j,l)
    -
    247  hgt2(i,j) = dzabv
    -
    248  l2(i,j) = l
    -
    249  ENDIF
    -
    250 
    -
    251  IF (dzabv >= d500 .AND. dzabv < d1000 .AND. &
    -
    252  l <= lv .AND. l1(i,j) <= l2(i,j)) THEN
    -
    253  u1(i,j) = u(i,j,l)
    -
    254  v1(i,j) = v(i,j,l)
    -
    255  hgt1(i,j) = dzabv
    -
    256  l1(i,j) = l
    -
    257  ENDIF
    -
    258 ! CRA
    -
    259 
    -
    260  ENDDO
    -
    261  ENDDO
    -
    262  ENDDO
    -
    263 !
    -
    264 ! CASE WHERE THERE IS NO LEVEL WITH HEIGHT BETWEEN 5500 AND 6000
    -
    265 !
    -
    266  DO j=jstart,jstop
    -
    267  DO i=istart,istop
    -
    268  IF (count5(i,j) == 0) THEN
    -
    269  DO l=lm,1,-1
    -
    270  ie=i+ive(j)
    -
    271  iw=i+ivw(j)
    -
    272  jn=j+jvn
    -
    273  js=j+jvs
    -
    274  IF (gridtype=='B')THEN
    -
    275  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    -
    276  ELSE
    -
    277  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    -
    278  END IF
    -
    279 
    -
    280  dzabv=z2-htsfc(i,j)
    -
    281  IF (dzabv < d7000 .AND. dzabv >= d6000) THEN
    -
    282  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    -
    283  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    -
    284  count5(i,j) = 1
    -
    285  goto 30
    -
    286  ENDIF
    -
    287  ENDDO
    -
    288  ENDIF
    -
    289 30 CONTINUE
    -
    290  ENDDO
    -
    291  ENDDO
    -
    292 
    -
    293 !
    -
    294 !$omp parallel do private(i,j,umean6,vmean6,umean5,vmean5,umean1,vmean1,denom)
    -
    295 
    -
    296  DO j=jstart,jstop
    -
    297  DO i=istart,istop
    -
    298  IF (count6(i,j) > 0 .AND. count1(i,j) > 0 .AND. count5(i,j) > 0) THEN
    -
    299  umean5 = ust5(i,j) / count5(i,j)
    -
    300  vmean5 = vst5(i,j) / count5(i,j)
    -
    301  umean1 = ust1(i,j) / count1(i,j)
    -
    302  vmean1 = vst1(i,j) / count1(i,j)
    -
    303  umean6 = ust6(i,j) / count6(i,j)
    -
    304  vmean6 = vst6(i,j) / count6(i,j)
    -
    305 
    -
    306 !
    -
    307 ! COMPUTE STORM MOTION VECTOR
    -
    308 ! IT IS DEFINED AS 7.5 M/S TO THE RIGHT OF THE 0-6 KM MEAN
    -
    309 ! WIND CONSTRAINED ALONG A LINE WHICH IS BOTH PERPENDICULAR
    -
    310 ! TO THE 0-6 KM MEAN VERTICAL WIND SHEAR VECTOR AND PASSES
    -
    311 ! THROUGH THE 0-6 KM MEAN WIND. THE WIND SHEAR VECTOR IS
    -
    312 ! SET AS THE DIFFERENCE BETWEEN THE 5.5-6 KM WIND (THE HEAD
    -
    313 ! OF THE SHEAR VECTOR) AND THE 0-0.5 KM WIND (THE TAIL).
    -
    314 ! THIS IS FOR THE RIGHT-MOVING CASE; WE IGNORE THE LEFT MOVER.
    -
    315 
    -
    316 ! CRA
    -
    317  ushr6(i,j) = umean5 - umean1
    -
    318  vshr6(i,j) = vmean5 - vmean1
    -
    319 
    -
    320  denom = ushr6(i,j)*ushr6(i,j)+vshr6(i,j)*vshr6(i,j)
    -
    321  IF (denom /= 0.0) THEN
    -
    322  ust(i,j) = umean6 + (7.5*vshr6(i,j)/sqrt(denom))
    -
    323  vst(i,j) = vmean6 - (7.5*ushr6(i,j)/sqrt(denom))
    -
    324  ELSE
    -
    325  ust(i,j) = 0
    -
    326  vst(i,j) = 0
    -
    327  ENDIF
    -
    328  ELSE
    -
    329  ust(i,j) = 0.0
    -
    330  vst(i,j) = 0.0
    -
    331  ushr6(i,j) = 0.0
    -
    332  vshr6(i,j) = 0.0
    -
    333  ENDIF
    -
    334 
    -
    335  IF(l1(i,j) > 0 .AND. l2(i,j) > 0) THEN
    -
    336  umean(i,j) = u1(i,j) + (d1000 - hgt1(i,j))*(u2(i,j) - &
    -
    337  u1(i,j))/(hgt2(i,j) - hgt1(i,j))
    -
    338  vmean(i,j) = v1(i,j) + (d1000 - hgt1(i,j))*(v2(i,j) - &
    -
    339  v1(i,j))/(hgt2(i,j) - hgt1(i,j))
    -
    340  ELSE IF(l1(i,j) > 0 .AND. l2(i,j) == 0) THEN
    -
    341  umean(i,j) = u1(i,j)
    -
    342  vmean(i,j) = v1(i,j)
    -
    343  ELSE IF(l1(i,j) == 0 .AND. l2(i,j) > 0) THEN
    -
    344  umean(i,j) = u2(i,j)
    -
    345  vmean(i,j) = u2(i,j)
    -
    346  ELSE
    -
    347  umean(i,j) = 0.0
    -
    348  vmean(i,j) = 0.0
    -
    349  ENDIF
    -
    350 
    -
    351  IF(l1(i,j) > 0 .OR. l2(i,j) > 0) THEN
    -
    352  ushr05(i,j) = umean1 - u10(i,j)
    -
    353  vshr05(i,j) = vmean1 - v10(i,j)
    -
    354  ushr1(i,j) = umean(i,j) - u10(i,j)
    -
    355  vshr1(i,j) = vmean(i,j) - v10(i,j)
    -
    356  ELSE
    -
    357  ushr05(i,j) = 0.0
    -
    358  vshr05(i,j) = 0.0
    -
    359  ushr1(i,j) = 0.0
    -
    360  vshr1(i,j) = 0.0
    +
    243 
    +
    244  IF (dzabv < d6000 .AND. dzabv >= d5500 .AND. l <= lv) THEN
    +
    245  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    +
    246  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    +
    247  count5(i,j) = count5(i,j) + 1
    +
    248  ENDIF
    +
    249 
    +
    250  IF (dzabv < d500 .AND. l <= lv) THEN
    +
    251  ust1(i,j) = ust1(i,j) + uh(i,j,l)
    +
    252  vst1(i,j) = vst1(i,j) + vh(i,j,l)
    +
    253  count1(i,j) = count1(i,j) + 1
    +
    254  ENDIF
    +
    255 ! CRA
    +
    256  IF (dzabv >= d1000 .AND. dzabv <= d1500 .AND. l <= lv) THEN
    +
    257  u2(i,j) = u(i,j,l)
    +
    258  v2(i,j) = v(i,j,l)
    +
    259  hgt2(i,j) = dzabv
    +
    260  l2(i,j) = l
    +
    261  ENDIF
    +
    262 
    +
    263  IF (dzabv >= d500 .AND. dzabv < d1000 .AND. &
    +
    264  l <= lv .AND. l1(i,j) <= l2(i,j)) THEN
    +
    265  u1(i,j) = u(i,j,l)
    +
    266  v1(i,j) = v(i,j,l)
    +
    267  hgt1(i,j) = dzabv
    +
    268  l1(i,j) = l
    +
    269  ENDIF
    +
    270 ! CRA
    +
    271 
    +
    272  ENDDO
    +
    273  ENDDO
    +
    274  ENDDO
    +
    275 !
    +
    276 ! CASE WHERE THERE IS NO LEVEL WITH HEIGHT BETWEEN 5500 AND 6000
    +
    277 !
    +
    278  DO j=jstart,jstop
    +
    279  DO i=istart,istop
    +
    280  IF (count5(i,j) == 0) THEN
    +
    281  DO l=lm,1,-1
    +
    282  ie=i+ive(j)
    +
    283  iw=i+ivw(j)
    +
    284  jn=j+jvn
    +
    285  js=j+jvs
    +
    286  IF (gridtype=='B')THEN
    +
    287  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    +
    288  ELSE
    +
    289  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    +
    290  END IF
    +
    291 
    +
    292  dzabv=z2-htsfc(i,j)
    +
    293  IF (dzabv < d7000 .AND. dzabv >= d6000) THEN
    +
    294  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    +
    295  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    +
    296  count5(i,j) = 1
    +
    297  goto 30
    +
    298  ENDIF
    +
    299  ENDDO
    +
    300  ENDIF
    +
    301 30 CONTINUE
    +
    302  ENDDO
    +
    303  ENDDO
    +
    304 
    +
    305 !
    +
    306 !$omp parallel do private(i,j,umean6,vmean6,umean5,vmean5,umean1,vmean1,denom)
    +
    307 
    +
    308  DO j=jstart,jstop
    +
    309  DO i=istart,istop
    +
    310  IF (count6(i,j) > 0 .AND. count1(i,j) > 0 .AND. count5(i,j) > 0) THEN
    +
    311  umean5 = ust5(i,j) / count5(i,j)
    +
    312  vmean5 = vst5(i,j) / count5(i,j)
    +
    313  umean1 = ust1(i,j) / count1(i,j)
    +
    314  vmean1 = vst1(i,j) / count1(i,j)
    +
    315  umean6 = ust6(i,j) / count6(i,j)
    +
    316  vmean6 = vst6(i,j) / count6(i,j)
    +
    317 
    +
    318 !
    +
    319 ! COMPUTE STORM MOTION VECTOR
    +
    320 ! IT IS DEFINED AS 7.5 M/S TO THE RIGHT OF THE 0-6 KM MEAN
    +
    321 ! WIND CONSTRAINED ALONG A LINE WHICH IS BOTH PERPENDICULAR
    +
    322 ! TO THE 0-6 KM MEAN VERTICAL WIND SHEAR VECTOR AND PASSES
    +
    323 ! THROUGH THE 0-6 KM MEAN WIND. THE WIND SHEAR VECTOR IS
    +
    324 ! SET AS THE DIFFERENCE BETWEEN THE 5.5-6 KM WIND (THE HEAD
    +
    325 ! OF THE SHEAR VECTOR) AND THE 0-0.5 KM WIND (THE TAIL).
    +
    326 ! THIS IS FOR THE RIGHT-MOVING CASE; WE IGNORE THE LEFT MOVER.
    +
    327 
    +
    328 ! CRA
    +
    329  ushr6(i,j) = umean5 - umean1
    +
    330  vshr6(i,j) = vmean5 - vmean1
    +
    331 
    +
    332  denom = ushr6(i,j)*ushr6(i,j)+vshr6(i,j)*vshr6(i,j)
    +
    333  IF (denom /= 0.0) THEN
    +
    334  ust(i,j) = umean6 + (7.5*vshr6(i,j)/sqrt(denom))
    +
    335  vst(i,j) = vmean6 - (7.5*ushr6(i,j)/sqrt(denom))
    +
    336  ELSE
    +
    337  ust(i,j) = 0
    +
    338  vst(i,j) = 0
    +
    339  ENDIF
    +
    340  ELSE
    +
    341  ust(i,j) = 0.0
    +
    342  vst(i,j) = 0.0
    +
    343  ushr6(i,j) = 0.0
    +
    344  vshr6(i,j) = 0.0
    +
    345  ENDIF
    +
    346 
    +
    347  IF(l1(i,j) > 0 .AND. l2(i,j) > 0) THEN
    +
    348  umean(i,j) = u1(i,j) + (d1000 - hgt1(i,j))*(u2(i,j) - &
    +
    349  u1(i,j))/(hgt2(i,j) - hgt1(i,j))
    +
    350  vmean(i,j) = v1(i,j) + (d1000 - hgt1(i,j))*(v2(i,j) - &
    +
    351  v1(i,j))/(hgt2(i,j) - hgt1(i,j))
    +
    352  ELSE IF(l1(i,j) > 0 .AND. l2(i,j) == 0) THEN
    +
    353  umean(i,j) = u1(i,j)
    +
    354  vmean(i,j) = v1(i,j)
    +
    355  ELSE IF(l1(i,j) == 0 .AND. l2(i,j) > 0) THEN
    +
    356  umean(i,j) = u2(i,j)
    +
    357  vmean(i,j) = u2(i,j)
    +
    358  ELSE
    +
    359  umean(i,j) = 0.0
    +
    360  vmean(i,j) = 0.0
    361  ENDIF
    -
    362 ! CRA
    -
    363 
    -
    364 !tgs USHR = UMEAN5 - UMEAN1
    -
    365 ! VSHR = VMEAN5 - VMEAN1
    -
    366 
    -
    367 ! UST(I,J) = UMEAN6 + (7.5*VSHR/SQRT(USHR*USHR+VSHR*VSHR))
    -
    368 ! VST(I,J) = VMEAN6 - (7.5*USHR/SQRT(USHR*USHR+VSHR*VSHR))
    -
    369 ! ELSE
    -
    370 ! UST(I,J) = 0.0
    -
    371 ! VST(I,J) = 0.0
    -
    372 ! ENDIF
    -
    373 
    -
    374  ENDDO
    -
    375  ENDDO
    -
    376 !
    -
    377 ! COMPUTE STORM-RELATIVE HELICITY
    -
    378 !
    -
    379 !!$omp parallel do private(i,j,n,l,du1,du2,dv1,dv2,dz,dz1,dz2,dzabv,ie,iw,jn,js,z1,z2,z3)
    -
    380  DO n=1,2 ! for dfferent helicity depth
    -
    381  DO l = 2,lm-1
    -
    382  if(gridtype /= 'A')then
    -
    383  call exch(zint(1,jsta_2l,l))
    -
    384  call exch(zint(1,jsta_2l,l+1))
    -
    385  end if
    -
    386  DO j=jstart,jstop
    -
    387  DO i=istart,istop
    -
    388  iw=i+ivw(j)
    -
    389  ie=i+ive(j)
    -
    390  jn=j+jvn
    -
    391  js=j+jvs
    -
    392  IF (gridtype=='B')THEN
    -
    393  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    -
    394  zmid(i,jn,l)+zmid(ie,jn,l))
    -
    395  ELSE
    -
    396  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    -
    397  zmid(i,jn,l)+zmid(i,js,l))
    -
    398  END IF
    -
    399  dzabv=z2-htsfc(i,j)
    -
    400 !
    -
    401  IF(dzabv < depth(n) .AND. l <= nint(lmv(i,j)))THEN
    -
    402  IF (gridtype=='B')THEN
    -
    403  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    -
    404  zmid(i,jn,l+1)+zmid(ie,jn,l+1))
    -
    405  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    -
    406  zmid(i,jn,l-1)+zmid(ie,jn,l-1))
    -
    407  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    -
    408  zint(i,jn,l)+zint(ie,jn,l))- &
    -
    409  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    -
    410  zint(i,jn,l+1)+zint(ie,jn,l+1)))
    -
    411  ELSE
    -
    412  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    -
    413  zmid(i,jn,l+1)+zmid(i,js,l+1))
    -
    414  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    -
    415  zmid(i,jn,l-1)+zmid(i,js,l-1))
    -
    416  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    -
    417  zint(i,js,l)+zint(i,jn,l))- &
    -
    418  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    -
    419  zint(i,js,l+1)+zint(i,jn,l+1)))
    -
    420  END IF
    -
    421  dz1 = z1-z2
    -
    422  dz2 = z2-z3
    -
    423  du1 = uh(i,j,l+1)-uh(i,j,l)
    -
    424  du2 = uh(i,j,l)-uh(i,j,l-1)
    -
    425  dv1 = vh(i,j,l+1)-vh(i,j,l)
    -
    426  dv2 = vh(i,j,l)-vh(i,j,l-1)
    -
    427  IF( l >= lupp(i,j) .AND. l <= llow(i,j) ) THEN
    -
    428  IF( vh(i,j,l) <spval.and.uh(i,j,l) <spval.and. &
    -
    429  vh(i,j,l+1)<spval.and.uh(i,j,l+1)<spval.and. &
    -
    430  vh(i,j,l-1)<spval.and.uh(i,j,l-1)<spval.and. &
    -
    431  vst(i,j) <spval.and.ust(i,j) <spval) &
    -
    432  heli(i,j,n) = ((vh(i,j,l)-vst(i,j))* &
    -
    433  (dz2*(du1/dz1)+dz1*(du2/dz2)) &
    -
    434  - (uh(i,j,l)-ust(i,j))* &
    -
    435  (dz2*(dv1/dz1)+dz1*(dv2/dz2))) &
    -
    436  *dz/(dz1+dz2)+heli(i,j,n)
    -
    437  ENDIF
    -
    438  IF(lupp(i,j) == llow(i,j)) heli(i,j,n) = 0.
    -
    439 
    -
    440 ! if(i==im/2.and.j==(jsta+jend)/2)print*,'Debug Helicity',depth(N),l,dz1,dz2,du1, &
    -
    441 ! du2,dv1,dv2,ust(i,j),vst(i,j)
    -
    442  ENDIF
    -
    443  ENDDO
    -
    444  ENDDO
    -
    445  ENDDO
    -
    446  END DO ! end of different helicity depth
    -
    447 
    -
    448 ! CRITICAL ANGLE
    -
    449 ! the angle between the storm-relative wind at the surface and the
    -
    450 ! 0-500 m AGL shear vector
    -
    451 ! https://www.spc.noaa.gov/exper/mesoanalysis/help/help_crit.html
    -
    452 
    -
    453  DO j=jstart,jstop
    -
    454  DO i=istart,istop
    -
    455  IF(vshr05(i,j)<spval.and.ushr05(i,j)<spval.and. &
    -
    456  vst(i,j)<spval.and.ust(i,j)<spval) THEN
    -
    457  cangle(i,j)=atan2(vshr05(i,j),ushr05(i,j))-atan2(vst(i,j),ust(i,j))
    -
    458  cangle(i,j)=(cangle(i,j)/pi)*180.
    -
    459  IF(cangle(i,j) > 180.) cangle(i,j)=360.-cangle(i,j)
    -
    460  IF(cangle(i,j) < 0. .AND. cangle(i,j) >= -180.) cangle(i,j)=-cangle(i,j)
    -
    461  IF(cangle(i,j) < -180.) cangle(i,j)=360.+cangle(i,j)
    -
    462  ELSE
    -
    463  cangle(i,j)=spval
    -
    464  ENDIF
    -
    465  ENDDO
    -
    466  ENDDO
    -
    467 !
    -
    468 ! END OF ROUTINE.
    -
    469 !
    -
    470  RETURN
    -
    471  END
    +
    362 
    +
    363  IF(l1(i,j) > 0 .OR. l2(i,j) > 0) THEN
    +
    364  ushr05(i,j) = umean1 - u10(i,j)
    +
    365  vshr05(i,j) = vmean1 - v10(i,j)
    +
    366  ushr1(i,j) = umean(i,j) - u10(i,j)
    +
    367  vshr1(i,j) = vmean(i,j) - v10(i,j)
    +
    368  ELSE
    +
    369  ushr05(i,j) = 0.0
    +
    370  vshr05(i,j) = 0.0
    +
    371  ushr1(i,j) = 0.0
    +
    372  vshr1(i,j) = 0.0
    +
    373  ENDIF
    +
    374 ! CRA
    +
    375 
    +
    376 !tgs USHR = UMEAN5 - UMEAN1
    +
    377 ! VSHR = VMEAN5 - VMEAN1
    +
    378 
    +
    379 ! UST(I,J) = UMEAN6 + (7.5*VSHR/SQRT(USHR*USHR+VSHR*VSHR))
    +
    380 ! VST(I,J) = VMEAN6 - (7.5*USHR/SQRT(USHR*USHR+VSHR*VSHR))
    +
    381 ! ELSE
    +
    382 ! UST(I,J) = 0.0
    +
    383 ! VST(I,J) = 0.0
    +
    384 ! ENDIF
    +
    385 
    +
    386  ENDDO
    +
    387  ENDDO
    +
    388 !
    +
    389 ! COMPUTE STORM-RELATIVE HELICITY
    +
    390 !
    +
    391 !!$omp parallel do private(i,j,n,l,du1,du2,dv1,dv2,dz,dz1,dz2,dzabv,ie,iw,jn,js,z1,z2,z3)
    +
    392  DO n=1,2 ! for dfferent helicity depth
    +
    393  DO l = 2,lm-1
    +
    394  if(gridtype /= 'A')then
    +
    395  call exch(zint(1,jsta_2l,l))
    +
    396  call exch(zint(1,jsta_2l,l+1))
    +
    397  end if
    +
    398  DO j=jstart,jstop
    +
    399  DO i=istart,istop
    +
    400  iw=i+ivw(j)
    +
    401  ie=i+ive(j)
    +
    402  jn=j+jvn
    +
    403  js=j+jvs
    +
    404  IF (gridtype=='B')THEN
    +
    405  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    +
    406  zmid(i,jn,l)+zmid(ie,jn,l))
    +
    407  ELSE
    +
    408  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    +
    409  zmid(i,jn,l)+zmid(i,js,l))
    +
    410  END IF
    +
    411  dzabv=z2-htsfc(i,j)
    +
    412 !
    +
    413  IF(dzabv < depth(n) .AND. l <= nint(lmv(i,j)))THEN
    +
    414  IF (gridtype=='B')THEN
    +
    415  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    +
    416  zmid(i,jn,l+1)+zmid(ie,jn,l+1))
    +
    417  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    +
    418  zmid(i,jn,l-1)+zmid(ie,jn,l-1))
    +
    419  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    +
    420  zint(i,jn,l)+zint(ie,jn,l))- &
    +
    421  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    +
    422  zint(i,jn,l+1)+zint(ie,jn,l+1)))
    +
    423  ELSE
    +
    424  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    +
    425  zmid(i,jn,l+1)+zmid(i,js,l+1))
    +
    426  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    +
    427  zmid(i,jn,l-1)+zmid(i,js,l-1))
    +
    428  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    +
    429  zint(i,js,l)+zint(i,jn,l))- &
    +
    430  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    +
    431  zint(i,js,l+1)+zint(i,jn,l+1)))
    +
    432  END IF
    +
    433  dz1 = z1-z2
    +
    434  dz2 = z2-z3
    +
    435  du1 = uh(i,j,l+1)-uh(i,j,l)
    +
    436  du2 = uh(i,j,l)-uh(i,j,l-1)
    +
    437  dv1 = vh(i,j,l+1)-vh(i,j,l)
    +
    438  dv2 = vh(i,j,l)-vh(i,j,l-1)
    +
    439  IF( l >= lupp(i,j) .AND. l <= llow(i,j) ) THEN
    +
    440  IF( vh(i,j,l) <spval.and.uh(i,j,l) <spval.and. &
    +
    441  vh(i,j,l+1)<spval.and.uh(i,j,l+1)<spval.and. &
    +
    442  vh(i,j,l-1)<spval.and.uh(i,j,l-1)<spval.and. &
    +
    443  vst(i,j) <spval.and.ust(i,j) <spval) &
    +
    444  heli(i,j,n) = ((vh(i,j,l)-vst(i,j))* &
    +
    445  (dz2*(du1/dz1)+dz1*(du2/dz2)) &
    +
    446  - (uh(i,j,l)-ust(i,j))* &
    +
    447  (dz2*(dv1/dz1)+dz1*(dv2/dz2))) &
    +
    448  *dz/(dz1+dz2)+heli(i,j,n)
    +
    449  ENDIF
    +
    450  IF(lupp(i,j) == llow(i,j)) heli(i,j,n) = 0.
    +
    451 
    +
    452 ! if(i==im/2.and.j==(jsta+jend)/2)print*,'Debug Helicity',depth(N),l,dz1,dz2,du1, &
    +
    453 ! du2,dv1,dv2,ust(i,j),vst(i,j)
    +
    454  ENDIF
    +
    455  ENDDO
    +
    456  ENDDO
    +
    457  ENDDO
    +
    458  END DO ! end of different helicity depth
    +
    459 
    +
    460 ! CRITICAL ANGLE
    +
    461 ! the angle between the storm-relative wind at the surface and the
    +
    462 ! 0-500 m AGL shear vector
    +
    463 ! https://www.spc.noaa.gov/exper/mesoanalysis/help/help_crit.html
    +
    464 
    +
    465  DO j=jstart,jstop
    +
    466  DO i=istart,istop
    +
    467  IF(vshr05(i,j)<spval.and.ushr05(i,j)<spval.and. &
    +
    468  vst(i,j)<spval.and.ust(i,j)<spval) THEN
    +
    469  cangle(i,j)=atan2(vshr05(i,j),ushr05(i,j))-atan2(vst(i,j),ust(i,j))
    +
    470  cangle(i,j)=(cangle(i,j)/pi)*180.
    +
    471  IF(cangle(i,j) > 180.) cangle(i,j)=360.-cangle(i,j)
    +
    472  IF(cangle(i,j) < 0. .AND. cangle(i,j) >= -180.) cangle(i,j)=-cangle(i,j)
    +
    473  IF(cangle(i,j) < -180.) cangle(i,j)=360.+cangle(i,j)
    +
    474  ELSE
    +
    475  cangle(i,j)=spval
    +
    476  ENDIF
    +
    477  ENDDO
    +
    478  ENDDO
    +
    479 !
    +
    480 ! END OF ROUTINE.
    +
    481 !
    +
    482  RETURN
    +
    483  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    +
    calhel2
    subroutine calhel2(LLOW, LUPP, DEPTH, UST, VST, HELI, CANGLE)
    Subroutine that computes storm relative helicity.
    Definition: CALHEL2.f:57
    masks
    Definition: MASKS_mod.f:1
    params_mod
    Definition: params.F:1
    - +
    lookup_mod
    Definition: LOOKUP.f:1
    @@ -548,7 +552,7 @@
  • sorc
  • ncep_post.fd
  • CALHEL2.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALHEL3_8f.html b/CALHEL3_8f.html index 82b6380b1..2701df103 100644 --- a/CALHEL3_8f.html +++ b/CALHEL3_8f.html @@ -3,7 +3,7 @@ - + UPP: CALHEL3.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,21 +116,21 @@ - - - + + +

    Functions/Subroutines

    subroutine CALHEL3 (LLOW, LUPP, UST, VST, HELI)
     This routine computes estimated storm motion and storm-relative environmental helicity. More...
     
    subroutine calhel3 (LLOW, LUPP, UST, VST, HELI)
     Subroutine that computes storm relative helicity. More...
     

    Detailed Description

    Subroutine that computes storm relative helicity.

    Definition in file CALHEL3.f.

    Function/Subroutine Documentation

    - +
    - + @@ -167,9 +167,7 @@
    subroutine CALHEL3 subroutine calhel3 ( integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in)  LLOW,
    -

    This routine computes estimated storm motion and storm-relative environmental helicity.

    -

    (Davies-Jones et al 1990) the algorithm processd as follows.

    -

    The storm motion computation no longer employs the Davies and Johns (1993) method which defined storm motion as 30 degress to the right of the 0-6 km mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees to the right for speeds greater than 15 m/s. Instead, we now use the dynamic method (Bunkers et al. 1988) which has been found to do better in cases with 'non-classic' hodographs (such as Northwest-flow events) and do as well or better than the old method in more classic situations.

    +

    Subroutine that computes storm relative helicity.

    Parameters
    @@ -177,49 +175,13 @@ - - - - -
    [in]LLOWLower bound CAPE>=100 and CINS>=-250.
    [out]USTEstimated U Component (m/s) Of Storm motion.
    [out]VSTEstimated V Component (m/s) Of Storm motion.
    [out]HELIStorm-relative heliciry (m**2/s**2).
    [out]CANGLECritical angle.
    [out]USHR1U Component (m/s) Of 0-1 km shear.
    [out]VSHR1V Component (m/s) Of 0-1 km shear.
    [out]USHR6U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear.
    [out]VSHR6V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear.
    -

    Program history log:

    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    Date Programmer Comments
    1994-08-22 Michael Baldwin Initial
    1997-03-27 Michael Baldwin Speed up code
    1998-06-15 T Black Conversion from 1-D to 2-D
    2000-01-04 Jim Tuccillo MPI Version
    2000-01-10 G Manikin Changed to Bunkers method
    2002-05-22 G Manikin Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths
    2003-03-25 G Manikin Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method
    2004-04-16 M Pyle Minimal modifications but put into NMM WRFPOST code
    2005-02-25 H Chuang Add computation for ARW A grid
    2005-07-07 Binbin Zhou Add RSM for A grid
    2019-09-03 J Meng Modified to compute effective helicity and critical angle
    2021-03-15 E Colon CALHEL2 modified to compute effective rather than fixed layer helicity
    2021-09-02 Bo Cui Decompose UPP in X direction
    -
    Author
    Michael Baldwin W/NP2
    -
    Date
    1994-08-22
    -

    Definition at line 45 of file CALHEL3.f.

    +

    Definition at line 56 of file CALHEL3.f.

    + +

    Referenced by miscln().

    @@ -231,7 +193,7 @@

    Program history log:

  • sorc
  • ncep_post.fd
  • CALHEL3.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5
    diff --git a/CALHEL3_8f.js b/CALHEL3_8f.js index d84d6fd10..b9e22b69c 100644 --- a/CALHEL3_8f.js +++ b/CALHEL3_8f.js @@ -1,4 +1,4 @@ var CALHEL3_8f = [ - [ "CALHEL3", "CALHEL3_8f.html#acdb3b85f8587551cfd5d86fc273cc31a", null ] + [ "calhel3", "CALHEL3_8f.html#a5990e8bebcc552367936f33b8258a8ba", null ] ]; \ No newline at end of file diff --git a/CALHEL3_8f_source.html b/CALHEL3_8f_source.html index 941dff33c..4ee127ff5 100644 --- a/CALHEL3_8f_source.html +++ b/CALHEL3_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALHEL3.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -108,416 +108,420 @@
    Go to the documentation of this file.
    1 
    3 !
    -
    45  SUBROUTINE calhel3(LLOW,LUPP,UST,VST,HELI)
    -
    46 
    -
    47 !
    -
    48  use vrbls3d, only: zmid, uh, vh, u, v, zint
    -
    49  use vrbls2d, only: fis, u10, v10
    -
    50  use masks, only: lmv
    -
    51  use params_mod, only: g
    -
    52  use lookup_mod, only: itb,jtb,itbq,jtbq
    -
    53  use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, &
    -
    54  lm, im, jm, me, spval, &
    -
    55  ista, iend, ista_m, iend_m, ista_2l, iend_2u
    -
    56  use gridspec_mod, only: gridtype
    -
    57 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    58  implicit none
    -
    59 !
    -
    60  real,PARAMETER :: p150=15000.0,p300=30000.0,s15=15.0
    -
    61  real,PARAMETER :: d3000=3000.0,pi6=0.5235987756,pi9=0.34906585
    -
    62  real,PARAMETER :: d5500=5500.0,d6000=6000.0,d7000=7000.0
    -
    63  real,PARAMETER :: d500=500.0
    -
    64 ! CRA
    -
    65  real,PARAMETER :: d1000=1000.0
    -
    66  real,PARAMETER :: d1500=1500.0
    -
    67 ! CRA
    -
    68  REAL, PARAMETER :: pi = 3.1415927
    -
    69 
    +
    46 !-----------------------------------------------------------------------
    +
    48 !
    +
    54 !-----------------------------------------------------------------------
    +
    55 
    +
    56  SUBROUTINE calhel3(LLOW,LUPP,UST,VST,HELI)
    +
    57 
    +
    58 !
    +
    59  use vrbls3d, only: zmid, uh, vh, u, v, zint
    +
    60  use vrbls2d, only: fis, u10, v10
    +
    61  use masks, only: lmv
    +
    62  use params_mod, only: g
    +
    63  use lookup_mod, only: itb,jtb,itbq,jtbq
    +
    64  use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, &
    +
    65  lm, im, jm, me, spval, &
    +
    66  ista, iend, ista_m, iend_m, ista_2l, iend_2u
    +
    67  use gridspec_mod, only: gridtype
    +
    68 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    69  implicit none
    70 !
    -
    71 ! DECLARE VARIABLES
    -
    72 !
    -
    73  integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: llow, lupp
    -
    74  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: ust,vst
    -
    75  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(out) :: heli
    -
    76 !
    -
    77  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: htsfc, ust6, vst6, ust5, vst5, &
    -
    78  ust1, vst1, ushr1, vshr1, &
    -
    79  ushr6, vshr6, u1, v1, u2, v2, &
    -
    80  hgt1, hgt2, umean, vmean
    -
    81  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: ushr05,vshr05,elt,elb
    -
    82 
    -
    83 ! REAL HTSFC(IM,JM)
    -
    84 !
    -
    85 ! REAL UST6(IM,JM),VST6(IM,JM)
    -
    86 ! REAL UST5(IM,JM),VST5(IM,JM)
    -
    87 ! REAL UST1(IM,JM),VST1(IM,JM)
    -
    88 ! CRA
    -
    89 ! REAL USHR1(IM,JM),VSHR1(IM,JM),USHR6(IM,JM),VSHR6(IM,JM)
    -
    90 ! REAL U1(IM,JM),V1(IM,JM),U2(IM,JM),V2(IM,JM)
    -
    91 ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM)
    -
    92 ! CRA
    +
    71  real,PARAMETER :: p150=15000.0,p300=30000.0,s15=15.0
    +
    72  real,PARAMETER :: d3000=3000.0,pi6=0.5235987756,pi9=0.34906585
    +
    73  real,PARAMETER :: d5500=5500.0,d6000=6000.0,d7000=7000.0
    +
    74  real,PARAMETER :: d500=500.0
    +
    75 ! CRA
    +
    76  real,PARAMETER :: d1000=1000.0
    +
    77  real,PARAMETER :: d1500=1500.0
    +
    78 ! CRA
    +
    79  REAL, PARAMETER :: pi = 3.1415927
    +
    80 
    +
    81 !
    +
    82 ! DECLARE VARIABLES
    +
    83 !
    +
    84  integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: llow, lupp
    +
    85  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: ust,vst
    +
    86  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(out) :: heli
    +
    87 !
    +
    88  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: htsfc, ust6, vst6, ust5, vst5, &
    +
    89  ust1, vst1, ushr1, vshr1, &
    +
    90  ushr6, vshr6, u1, v1, u2, v2, &
    +
    91  hgt1, hgt2, umean, vmean
    +
    92  real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: ushr05,vshr05,elt,elb
    93 
    -
    94  integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: count6, count5, count1, l1, l2
    -
    95 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM)
    -
    96 ! CRA
    -
    97 ! INTEGER L1(IM,JM),L2(IM,JM)
    -
    98 ! CRA
    -
    99 
    -
    100  INTEGER ive(jm),ivw(jm)
    -
    101  integer i,j,iw,ie,js,jn,jvn,jvs,l,n,lv
    -
    102  integer istart,istop,jstart,jstop
    -
    103  real z2,dzabv,umean5,vmean5,umean1,vmean1,umean6,vmean6, &
    -
    104  denom,z1,z3,dz,dz1,dz2,du1,du2,dv1,dv2
    -
    105 !
    -
    106 !****************************************************************
    -
    107 ! START CALHEL HERE
    -
    108 !
    -
    109 ! INITIALIZE ARRAYS.
    -
    110 !
    -
    111 !$omp parallel do private(i,j)
    -
    112  DO j=jsta,jend
    -
    113  DO i=ista,iend
    -
    114  ust(i,j) = 0.0
    -
    115  vst(i,j) = 0.0
    -
    116  heli(i,j) = 0.0
    -
    117  ust1(i,j) = 0.0
    -
    118  vst1(i,j) = 0.0
    -
    119  ust5(i,j) = 0.0
    -
    120  vst5(i,j) = 0.0
    -
    121  ust6(i,j) = 0.0
    -
    122  vst6(i,j) = 0.0
    -
    123  count6(i,j) = 0
    -
    124  count5(i,j) = 0
    -
    125  count1(i,j) = 0
    -
    126 ! CRA
    -
    127  ushr05(i,j) = 0.0
    -
    128  vshr05(i,j) = 0.0
    -
    129  ushr1(i,j) = 0.0
    -
    130  vshr1(i,j) = 0.0
    -
    131  ushr6(i,j) = 0.0
    -
    132  vshr6(i,j) = 0.0
    -
    133  u1(i,j) = 0.0
    -
    134  u2(i,j) = 0.0
    -
    135  v1(i,j) = 0.0
    -
    136  v2(i,j) = 0.0
    -
    137  umean(i,j) = 0.0
    -
    138  vmean(i,j) = 0.0
    -
    139  hgt1(i,j) = 0.0
    -
    140  hgt2(i,j) = 0.0
    -
    141  l1(i,j) = 0
    -
    142  l2(i,j) = 0
    -
    143 ! CRA
    -
    144 
    -
    145  ENDDO
    -
    146  ENDDO
    -
    147  IF(gridtype == 'E')THEN
    -
    148  jvn = 1
    -
    149  jvs = -1
    -
    150  do j=jsta,jend
    -
    151  ive(j) = mod(j,2)
    -
    152  ivw(j) = ive(j)-1
    -
    153  enddo
    -
    154  istart = ista_m
    -
    155  istop = iend_m
    -
    156  jstart = jsta_m
    -
    157  jstop = jend_m
    -
    158  ELSE IF(gridtype == 'B')THEN
    -
    159  jvn = 1
    -
    160  jvs = 0
    +
    94 ! REAL HTSFC(IM,JM)
    +
    95 !
    +
    96 ! REAL UST6(IM,JM),VST6(IM,JM)
    +
    97 ! REAL UST5(IM,JM),VST5(IM,JM)
    +
    98 ! REAL UST1(IM,JM),VST1(IM,JM)
    +
    99 ! CRA
    +
    100 ! REAL USHR1(IM,JM),VSHR1(IM,JM),USHR6(IM,JM),VSHR6(IM,JM)
    +
    101 ! REAL U1(IM,JM),V1(IM,JM),U2(IM,JM),V2(IM,JM)
    +
    102 ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM)
    +
    103 ! CRA
    +
    104 
    +
    105  integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: count6, count5, count1, l1, l2
    +
    106 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM)
    +
    107 ! CRA
    +
    108 ! INTEGER L1(IM,JM),L2(IM,JM)
    +
    109 ! CRA
    +
    110 
    +
    111  INTEGER ive(jm),ivw(jm)
    +
    112  integer i,j,iw,ie,js,jn,jvn,jvs,l,n,lv
    +
    113  integer istart,istop,jstart,jstop
    +
    114  real z2,dzabv,umean5,vmean5,umean1,vmean1,umean6,vmean6, &
    +
    115  denom,z1,z3,dz,dz1,dz2,du1,du2,dv1,dv2
    +
    116 !
    +
    117 !****************************************************************
    +
    118 ! START CALHEL HERE
    +
    119 !
    +
    120 ! INITIALIZE ARRAYS.
    +
    121 !
    +
    122 !$omp parallel do private(i,j)
    +
    123  DO j=jsta,jend
    +
    124  DO i=ista,iend
    +
    125  ust(i,j) = 0.0
    +
    126  vst(i,j) = 0.0
    +
    127  heli(i,j) = 0.0
    +
    128  ust1(i,j) = 0.0
    +
    129  vst1(i,j) = 0.0
    +
    130  ust5(i,j) = 0.0
    +
    131  vst5(i,j) = 0.0
    +
    132  ust6(i,j) = 0.0
    +
    133  vst6(i,j) = 0.0
    +
    134  count6(i,j) = 0
    +
    135  count5(i,j) = 0
    +
    136  count1(i,j) = 0
    +
    137 ! CRA
    +
    138  ushr05(i,j) = 0.0
    +
    139  vshr05(i,j) = 0.0
    +
    140  ushr1(i,j) = 0.0
    +
    141  vshr1(i,j) = 0.0
    +
    142  ushr6(i,j) = 0.0
    +
    143  vshr6(i,j) = 0.0
    +
    144  u1(i,j) = 0.0
    +
    145  u2(i,j) = 0.0
    +
    146  v1(i,j) = 0.0
    +
    147  v2(i,j) = 0.0
    +
    148  umean(i,j) = 0.0
    +
    149  vmean(i,j) = 0.0
    +
    150  hgt1(i,j) = 0.0
    +
    151  hgt2(i,j) = 0.0
    +
    152  l1(i,j) = 0
    +
    153  l2(i,j) = 0
    +
    154 ! CRA
    +
    155 
    +
    156  ENDDO
    +
    157  ENDDO
    +
    158  IF(gridtype == 'E')THEN
    +
    159  jvn = 1
    +
    160  jvs = -1
    161  do j=jsta,jend
    -
    162  ive(j)=1
    -
    163  ivw(j)=0
    +
    162  ive(j) = mod(j,2)
    +
    163  ivw(j) = ive(j)-1
    164  enddo
    165  istart = ista_m
    166  istop = iend_m
    167  jstart = jsta_m
    168  jstop = jend_m
    -
    169  ELSE
    -
    170  jvn = 0
    +
    169  ELSE IF(gridtype == 'B')THEN
    +
    170  jvn = 1
    171  jvs = 0
    172  do j=jsta,jend
    -
    173  ive(j) = 0
    -
    174  ivw(j) = 0
    +
    173  ive(j)=1
    +
    174  ivw(j)=0
    175  enddo
    -
    176  istart = ista
    -
    177  istop = iend
    -
    178  jstart = jsta
    -
    179  jstop = jend
    -
    180  END IF
    -
    181 !
    -
    182 ! LOOP OVER HORIZONTAL GRID.
    -
    183 !
    -
    184 ! CALL EXCH(RES(1,jsta_2l)
    -
    185 ! CALL EXCH(PD()
    -
    186 
    -
    187 ! DO L = 1,LP1
    -
    188 ! CALL EXCH(ZINT(1,jsta_2l,L))
    -
    189 ! END DO
    -
    190 !
    -
    191 !!$omp parallel do private(htsfc,ie,iw)
    -
    192  IF(gridtype /= 'A') CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
    -
    193  DO l = 1,lm
    -
    194  IF(gridtype /= 'A') CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
    -
    195  DO j=jstart,jstop
    -
    196  DO i=istart,istop
    -
    197  ie = i+ive(j)
    -
    198  iw = i+ivw(j)
    -
    199  jn = j+jvn
    -
    200  js = j+jvs
    -
    201 !mp PDSLVK=(PD(IW,J)*RES(IW,J)+PD(IE,J)*RES(IE,J)+
    -
    202 !mp 1 PD(I,J+1)*RES(I,J+1)+PD(I,J-1)*RES(I,J-1))*0.25
    -
    203 !mp PSFCK=AETA(LMV(I,J))*PDSLVK+PT
    -
    204  IF (gridtype=='B')THEN
    -
    205  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))
    -
    206 !
    -
    207 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    -
    208 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    -
    209 !
    -
    210  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    -
    211  ELSE
    -
    212  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))
    -
    213 !
    -
    214 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    -
    215 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    -
    216 !
    -
    217  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    -
    218  END IF
    -
    219  dzabv = z2-htsfc(i,j)
    -
    220 
    -
    221  lv = nint(lmv(i,j))
    -
    222  IF (dzabv <= d6000 .AND. l <= lv) THEN
    -
    223  ust6(i,j) = ust6(i,j) + uh(i,j,l)
    -
    224  vst6(i,j) = vst6(i,j) + vh(i,j,l)
    -
    225  count6(i,j) = count6(i,j) + 1
    -
    226  ENDIF
    -
    227 
    -
    228  IF (dzabv < d6000 .AND. dzabv >= d5500 .AND. l <= lv) THEN
    -
    229  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    -
    230  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    -
    231  count5(i,j) = count5(i,j) + 1
    -
    232  ENDIF
    -
    233 
    -
    234  IF (dzabv < d500 .AND. l <= lv) THEN
    -
    235  ust1(i,j) = ust1(i,j) + uh(i,j,l)
    -
    236  vst1(i,j) = vst1(i,j) + vh(i,j,l)
    -
    237  count1(i,j) = count1(i,j) + 1
    -
    238  ENDIF
    -
    239 ! CRA
    -
    240  IF (dzabv >= d1000 .AND. dzabv <= d1500 .AND. l <= lv) THEN
    -
    241  u2(i,j) = u(i,j,l)
    -
    242  v2(i,j) = v(i,j,l)
    -
    243  hgt2(i,j) = dzabv
    -
    244  l2(i,j) = l
    -
    245  ENDIF
    -
    246 
    -
    247  IF (dzabv >= d500 .AND. dzabv < d1000 .AND. &
    -
    248  l <= lv .AND. l1(i,j) <= l2(i,j)) THEN
    -
    249  u1(i,j) = u(i,j,l)
    -
    250  v1(i,j) = v(i,j,l)
    -
    251  hgt1(i,j) = dzabv
    -
    252  l1(i,j) = l
    -
    253  ENDIF
    -
    254 ! CRA
    -
    255 
    -
    256  ENDDO
    -
    257  ENDDO
    -
    258  ENDDO
    -
    259 !
    -
    260 ! CASE WHERE THERE IS NO LEVEL WITH HEIGHT BETWEEN 5500 AND 6000
    -
    261 !
    -
    262  DO j=jstart,jstop
    -
    263  DO i=istart,istop
    -
    264  IF (count5(i,j) == 0) THEN
    -
    265  DO l=lm,1,-1
    -
    266  ie=i+ive(j)
    -
    267  iw=i+ivw(j)
    -
    268  jn=j+jvn
    -
    269  js=j+jvs
    -
    270  IF (gridtype=='B')THEN
    -
    271  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    -
    272  ELSE
    -
    273  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    -
    274  END IF
    -
    275 
    -
    276  dzabv=z2-htsfc(i,j)
    -
    277 
    -
    278  IF (dzabv < d7000 .AND. dzabv >= d6000) THEN
    -
    279  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    -
    280  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    -
    281  count5(i,j) = 1
    -
    282  goto 30
    -
    283  ENDIF
    -
    284  ENDDO
    -
    285  ENDIF
    -
    286 30 CONTINUE
    -
    287  ENDDO
    -
    288  ENDDO
    -
    289 
    -
    290 !
    -
    291 !$omp parallel do private(i,j,umean6,vmean6,umean5,vmean5,umean1,vmean1,denom)
    -
    292 
    -
    293  DO j=jstart,jstop
    -
    294  DO i=istart,istop
    -
    295  IF (count6(i,j) > 0 .AND. count1(i,j) > 0 .AND. count5(i,j) > 0) THEN
    -
    296  umean5 = ust5(i,j) / count5(i,j)
    -
    297  vmean5 = vst5(i,j) / count5(i,j)
    -
    298  umean1 = ust1(i,j) / count1(i,j)
    -
    299  vmean1 = vst1(i,j) / count1(i,j)
    -
    300  umean6 = ust6(i,j) / count6(i,j)
    -
    301  vmean6 = vst6(i,j) / count6(i,j)
    -
    302 
    -
    303 !
    -
    304 ! COMPUTE STORM MOTION VECTOR
    -
    305 ! IT IS DEFINED AS 7.5 M/S TO THE RIGHT OF THE 0-6 KM MEAN
    -
    306 ! WIND CONSTRAINED ALONG A LINE WHICH IS BOTH PERPENDICULAR
    -
    307 ! TO THE 0-6 KM MEAN VERTICAL WIND SHEAR VECTOR AND PASSES
    -
    308 ! THROUGH THE 0-6 KM MEAN WIND. THE WIND SHEAR VECTOR IS
    -
    309 ! SET AS THE DIFFERENCE BETWEEN THE 5.5-6 KM WIND (THE HEAD
    -
    310 ! OF THE SHEAR VECTOR) AND THE 0-0.5 KM WIND (THE TAIL).
    -
    311 ! THIS IS FOR THE RIGHT-MOVING CASE; WE IGNORE THE LEFT MOVER.
    -
    312 
    -
    313 ! CRA
    -
    314  ushr6(i,j) = umean5 - umean1
    -
    315  vshr6(i,j) = vmean5 - vmean1
    -
    316 
    -
    317  denom = ushr6(i,j)*ushr6(i,j)+vshr6(i,j)*vshr6(i,j)
    -
    318  IF (denom /= 0.0) THEN
    -
    319  ust(i,j) = umean6 + (7.5*vshr6(i,j)/sqrt(denom))
    -
    320  vst(i,j) = vmean6 - (7.5*ushr6(i,j)/sqrt(denom))
    -
    321  ELSE
    -
    322  ust(i,j) = 0
    -
    323  vst(i,j) = 0
    -
    324  ENDIF
    -
    325  ELSE
    -
    326  ust(i,j) = 0.0
    -
    327  vst(i,j) = 0.0
    -
    328  ushr6(i,j) = 0.0
    -
    329  vshr6(i,j) = 0.0
    -
    330  ENDIF
    -
    331 
    -
    332  IF(l1(i,j) > 0 .AND. l2(i,j) > 0) THEN
    -
    333  umean(i,j) = u1(i,j) + (d1000 - hgt1(i,j))*(u2(i,j) - &
    -
    334  u1(i,j))/(hgt2(i,j) - hgt1(i,j))
    -
    335  vmean(i,j) = v1(i,j) + (d1000 - hgt1(i,j))*(v2(i,j) - &
    -
    336  v1(i,j))/(hgt2(i,j) - hgt1(i,j))
    -
    337  ELSE IF(l1(i,j) > 0 .AND. l2(i,j) == 0) THEN
    -
    338  umean(i,j) = u1(i,j)
    -
    339  vmean(i,j) = v1(i,j)
    -
    340  ELSE IF(l1(i,j) == 0 .AND. l2(i,j) > 0) THEN
    -
    341  umean(i,j) = u2(i,j)
    -
    342  vmean(i,j) = u2(i,j)
    -
    343  ELSE
    -
    344  umean(i,j) = 0.0
    -
    345  vmean(i,j) = 0.0
    -
    346  ENDIF
    -
    347 
    -
    348  IF(l1(i,j) > 0 .OR. l2(i,j) > 0) THEN
    -
    349  ushr05(i,j) = umean1 - u10(i,j)
    -
    350  vshr05(i,j) = vmean1 - v10(i,j)
    -
    351  ushr1(i,j) = umean(i,j) - u10(i,j)
    -
    352  vshr1(i,j) = vmean(i,j) - v10(i,j)
    -
    353  ELSE
    -
    354  ushr05(i,j) = 0.0
    -
    355  vshr05(i,j) = 0.0
    -
    356  ushr1(i,j) = 0.0
    -
    357  vshr1(i,j) = 0.0
    -
    358  ENDIF
    -
    359 ! CRA
    -
    360 
    -
    361 !tgs USHR = UMEAN5 - UMEAN1
    -
    362 ! VSHR = VMEAN5 - VMEAN1
    -
    363 
    -
    364 ! UST(I,J) = UMEAN6 + (7.5*VSHR/SQRT(USHR*USHR+VSHR*VSHR))
    -
    365 ! VST(I,J) = VMEAN6 - (7.5*USHR/SQRT(USHR*USHR+VSHR*VSHR))
    -
    366 ! ELSE
    -
    367 ! UST(I,J) = 0.0
    -
    368 ! VST(I,J) = 0.0
    -
    369 ! ENDIF
    -
    370  ENDDO
    -
    371  ENDDO
    -
    372 !
    -
    373 ! COMPUTE STORM-RELATIVE HELICITY
    -
    374 !
    -
    375 !!$omp parallel do private(i,j,n,l,du1,du2,dv1,dv2,dz,dz1,dz2,dzabv,ie,iw,jn,js,z1,z2,z3)
    -
    376  DO n=1,2 ! for dfferent helicity depth
    -
    377  DO l = 2,lm-1
    -
    378  if(gridtype /= 'A')then
    -
    379  call exch(zint(1,jsta_2l,l))
    -
    380  call exch(zint(1,jsta_2l,l+1))
    -
    381  end if
    -
    382  DO j=jstart,jstop
    -
    383  DO i=istart,istop
    -
    384  iw=i+ivw(j)
    -
    385  ie=i+ive(j)
    -
    386  jn=j+jvn
    -
    387  js=j+jvs
    -
    388  IF (gridtype=='B')THEN
    -
    389  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    -
    390  zmid(i,jn,l)+zmid(ie,jn,l))
    -
    391  ELSE
    -
    392  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    -
    393  zmid(i,jn,l)+zmid(i,js,l))
    -
    394  END IF
    -
    395  dzabv=z2-htsfc(i,j)
    -
    396  elt(i,j) = zint(i,j,lupp(i,j))-htsfc(i,j)
    -
    397  elb(i,j) = zint(i,j,llow(i,j))-htsfc(i,j)
    -
    398 
    -
    399 !
    -
    400  IF(dzabv <= elt(i,j) .AND. dzabv >= elb(i,j) .AND. l <= nint(lmv(i,j)))THEN
    -
    401  IF (gridtype=='B')THEN
    -
    402  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    -
    403  zmid(i,jn,l+1)+zmid(ie,jn,l+1))
    -
    404  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    -
    405  zmid(i,jn,l-1)+zmid(ie,jn,l-1))
    -
    406  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    -
    407  zint(i,jn,l)+zint(ie,jn,l))- &
    -
    408  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    -
    409  zint(i,jn,l+1)+zint(ie,jn,l+1)))
    -
    410  ELSE
    -
    411  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    -
    412  zmid(i,jn,l+1)+zmid(i,js,l+1))
    -
    413  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    -
    414  zmid(i,jn,l-1)+zmid(i,js,l-1))
    -
    415  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    -
    416  zint(i,js,l)+zint(i,jn,l))- &
    -
    417  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    -
    418  zint(i,js,l+1)+zint(i,jn,l+1)))
    -
    419  END IF
    -
    420  dz1 = z1-z2
    -
    421  dz2 = z2-z3
    -
    422  du1 = uh(i,j,l+1)-uh(i,j,l)
    -
    423  du2 = uh(i,j,l)-uh(i,j,l-1)
    -
    424  dv1 = vh(i,j,l+1)-vh(i,j,l)
    -
    425  dv2 = vh(i,j,l)-vh(i,j,l-1)
    -
    426  IF( l >= lupp(i,j) .AND. l <= llow(i,j) ) THEN
    -
    427  IF( vh(i,j,l) <spval.and.uh(i,j,l) <spval.and. &
    -
    428  vh(i,j,l+1)<spval.and.uh(i,j,l+1)<spval.and. &
    -
    429  vh(i,j,l-1)<spval.and.uh(i,j,l-1)<spval.and. &
    -
    430  vst(i,j) <spval.and.ust(i,j) <spval) &
    -
    431  heli(i,j) = ((vh(i,j,l)-vst(i,j))* &
    -
    432  (dz2*(du1/dz1)+dz1*(du2/dz2)) &
    -
    433  - (uh(i,j,l)-ust(i,j))* &
    -
    434  (dz2*(dv1/dz1)+dz1*(dv2/dz2))) &
    -
    435  *dz/(dz1+dz2)+heli(i,j)
    -
    436  ENDIF
    -
    437  IF(lupp(i,j) == llow(i,j)) heli(i,j) = 0.
    -
    438 
    -
    439 ! if(i==im/2.and.j==(jsta+jend)/2)print*,'Debug Helicity',depth(N),l,dz1,dz2,du1, &
    -
    440 ! du2,dv1,dv2,ust(i,j),vst(i,j)
    -
    441  ENDIF
    -
    442  ENDDO
    -
    443  ENDDO
    -
    444  ENDDO
    -
    445  END DO ! end of different helicity depth
    -
    446 
    -
    447 ! END OF ROUTINE.
    -
    448 !
    -
    449  RETURN
    -
    450  END
    +
    176  istart = ista_m
    +
    177  istop = iend_m
    +
    178  jstart = jsta_m
    +
    179  jstop = jend_m
    +
    180  ELSE
    +
    181  jvn = 0
    +
    182  jvs = 0
    +
    183  do j=jsta,jend
    +
    184  ive(j) = 0
    +
    185  ivw(j) = 0
    +
    186  enddo
    +
    187  istart = ista
    +
    188  istop = iend
    +
    189  jstart = jsta
    +
    190  jstop = jend
    +
    191  END IF
    +
    192 !
    +
    193 ! LOOP OVER HORIZONTAL GRID.
    +
    194 !
    +
    195 ! CALL EXCH(RES(1,jsta_2l)
    +
    196 ! CALL EXCH(PD()
    +
    197 
    +
    198 ! DO L = 1,LP1
    +
    199 ! CALL EXCH(ZINT(1,jsta_2l,L))
    +
    200 ! END DO
    +
    201 !
    +
    202 !!$omp parallel do private(htsfc,ie,iw)
    +
    203  IF(gridtype /= 'A') CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
    +
    204  DO l = 1,lm
    +
    205  IF(gridtype /= 'A') CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
    +
    206  DO j=jstart,jstop
    +
    207  DO i=istart,istop
    +
    208  ie = i+ive(j)
    +
    209  iw = i+ivw(j)
    +
    210  jn = j+jvn
    +
    211  js = j+jvs
    +
    212 !mp PDSLVK=(PD(IW,J)*RES(IW,J)+PD(IE,J)*RES(IE,J)+
    +
    213 !mp 1 PD(I,J+1)*RES(I,J+1)+PD(I,J-1)*RES(I,J-1))*0.25
    +
    214 !mp PSFCK=AETA(LMV(I,J))*PDSLVK+PT
    +
    215  IF (gridtype=='B')THEN
    +
    216  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))
    +
    217 !
    +
    218 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    +
    219 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    +
    220 !
    +
    221  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    +
    222  ELSE
    +
    223  htsfc(i,j) = (0.25/g)*(fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))
    +
    224 !
    +
    225 ! COMPUTE MASS WEIGHTED MEAN WIND IN THE 0-6 KM LAYER, THE
    +
    226 ! 0-0.5 KM LAYER, AND THE 5.5-6 KM LAYER
    +
    227 !
    +
    228  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    +
    229  END IF
    +
    230  dzabv = z2-htsfc(i,j)
    +
    231 
    +
    232  lv = nint(lmv(i,j))
    +
    233  IF (dzabv <= d6000 .AND. l <= lv) THEN
    +
    234  ust6(i,j) = ust6(i,j) + uh(i,j,l)
    +
    235  vst6(i,j) = vst6(i,j) + vh(i,j,l)
    +
    236  count6(i,j) = count6(i,j) + 1
    +
    237  ENDIF
    +
    238 
    +
    239  IF (dzabv < d6000 .AND. dzabv >= d5500 .AND. l <= lv) THEN
    +
    240  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    +
    241  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    +
    242  count5(i,j) = count5(i,j) + 1
    +
    243  ENDIF
    +
    244 
    +
    245  IF (dzabv < d500 .AND. l <= lv) THEN
    +
    246  ust1(i,j) = ust1(i,j) + uh(i,j,l)
    +
    247  vst1(i,j) = vst1(i,j) + vh(i,j,l)
    +
    248  count1(i,j) = count1(i,j) + 1
    +
    249  ENDIF
    +
    250 ! CRA
    +
    251  IF (dzabv >= d1000 .AND. dzabv <= d1500 .AND. l <= lv) THEN
    +
    252  u2(i,j) = u(i,j,l)
    +
    253  v2(i,j) = v(i,j,l)
    +
    254  hgt2(i,j) = dzabv
    +
    255  l2(i,j) = l
    +
    256  ENDIF
    +
    257 
    +
    258  IF (dzabv >= d500 .AND. dzabv < d1000 .AND. &
    +
    259  l <= lv .AND. l1(i,j) <= l2(i,j)) THEN
    +
    260  u1(i,j) = u(i,j,l)
    +
    261  v1(i,j) = v(i,j,l)
    +
    262  hgt1(i,j) = dzabv
    +
    263  l1(i,j) = l
    +
    264  ENDIF
    +
    265 ! CRA
    +
    266 
    +
    267  ENDDO
    +
    268  ENDDO
    +
    269  ENDDO
    +
    270 !
    +
    271 ! CASE WHERE THERE IS NO LEVEL WITH HEIGHT BETWEEN 5500 AND 6000
    +
    272 !
    +
    273  DO j=jstart,jstop
    +
    274  DO i=istart,istop
    +
    275  IF (count5(i,j) == 0) THEN
    +
    276  DO l=lm,1,-1
    +
    277  ie=i+ive(j)
    +
    278  iw=i+ivw(j)
    +
    279  jn=j+jvn
    +
    280  js=j+jvs
    +
    281  IF (gridtype=='B')THEN
    +
    282  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
    +
    283  ELSE
    +
    284  z2 = 0.25*(zmid(iw,j,l)+zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
    +
    285  END IF
    +
    286 
    +
    287  dzabv=z2-htsfc(i,j)
    +
    288 
    +
    289  IF (dzabv < d7000 .AND. dzabv >= d6000) THEN
    +
    290  ust5(i,j) = ust5(i,j) + uh(i,j,l)
    +
    291  vst5(i,j) = vst5(i,j) + vh(i,j,l)
    +
    292  count5(i,j) = 1
    +
    293  goto 30
    +
    294  ENDIF
    +
    295  ENDDO
    +
    296  ENDIF
    +
    297 30 CONTINUE
    +
    298  ENDDO
    +
    299  ENDDO
    +
    300 
    +
    301 !
    +
    302 !$omp parallel do private(i,j,umean6,vmean6,umean5,vmean5,umean1,vmean1,denom)
    +
    303 
    +
    304  DO j=jstart,jstop
    +
    305  DO i=istart,istop
    +
    306  IF (count6(i,j) > 0 .AND. count1(i,j) > 0 .AND. count5(i,j) > 0) THEN
    +
    307  umean5 = ust5(i,j) / count5(i,j)
    +
    308  vmean5 = vst5(i,j) / count5(i,j)
    +
    309  umean1 = ust1(i,j) / count1(i,j)
    +
    310  vmean1 = vst1(i,j) / count1(i,j)
    +
    311  umean6 = ust6(i,j) / count6(i,j)
    +
    312  vmean6 = vst6(i,j) / count6(i,j)
    +
    313 
    +
    314 !
    +
    315 ! COMPUTE STORM MOTION VECTOR
    +
    316 ! IT IS DEFINED AS 7.5 M/S TO THE RIGHT OF THE 0-6 KM MEAN
    +
    317 ! WIND CONSTRAINED ALONG A LINE WHICH IS BOTH PERPENDICULAR
    +
    318 ! TO THE 0-6 KM MEAN VERTICAL WIND SHEAR VECTOR AND PASSES
    +
    319 ! THROUGH THE 0-6 KM MEAN WIND. THE WIND SHEAR VECTOR IS
    +
    320 ! SET AS THE DIFFERENCE BETWEEN THE 5.5-6 KM WIND (THE HEAD
    +
    321 ! OF THE SHEAR VECTOR) AND THE 0-0.5 KM WIND (THE TAIL).
    +
    322 ! THIS IS FOR THE RIGHT-MOVING CASE; WE IGNORE THE LEFT MOVER.
    +
    323 
    +
    324 ! CRA
    +
    325  ushr6(i,j) = umean5 - umean1
    +
    326  vshr6(i,j) = vmean5 - vmean1
    +
    327 
    +
    328  denom = ushr6(i,j)*ushr6(i,j)+vshr6(i,j)*vshr6(i,j)
    +
    329  IF (denom /= 0.0) THEN
    +
    330  ust(i,j) = umean6 + (7.5*vshr6(i,j)/sqrt(denom))
    +
    331  vst(i,j) = vmean6 - (7.5*ushr6(i,j)/sqrt(denom))
    +
    332  ELSE
    +
    333  ust(i,j) = 0
    +
    334  vst(i,j) = 0
    +
    335  ENDIF
    +
    336  ELSE
    +
    337  ust(i,j) = 0.0
    +
    338  vst(i,j) = 0.0
    +
    339  ushr6(i,j) = 0.0
    +
    340  vshr6(i,j) = 0.0
    +
    341  ENDIF
    +
    342 
    +
    343  IF(l1(i,j) > 0 .AND. l2(i,j) > 0) THEN
    +
    344  umean(i,j) = u1(i,j) + (d1000 - hgt1(i,j))*(u2(i,j) - &
    +
    345  u1(i,j))/(hgt2(i,j) - hgt1(i,j))
    +
    346  vmean(i,j) = v1(i,j) + (d1000 - hgt1(i,j))*(v2(i,j) - &
    +
    347  v1(i,j))/(hgt2(i,j) - hgt1(i,j))
    +
    348  ELSE IF(l1(i,j) > 0 .AND. l2(i,j) == 0) THEN
    +
    349  umean(i,j) = u1(i,j)
    +
    350  vmean(i,j) = v1(i,j)
    +
    351  ELSE IF(l1(i,j) == 0 .AND. l2(i,j) > 0) THEN
    +
    352  umean(i,j) = u2(i,j)
    +
    353  vmean(i,j) = u2(i,j)
    +
    354  ELSE
    +
    355  umean(i,j) = 0.0
    +
    356  vmean(i,j) = 0.0
    +
    357  ENDIF
    +
    358 
    +
    359  IF(l1(i,j) > 0 .OR. l2(i,j) > 0) THEN
    +
    360  ushr05(i,j) = umean1 - u10(i,j)
    +
    361  vshr05(i,j) = vmean1 - v10(i,j)
    +
    362  ushr1(i,j) = umean(i,j) - u10(i,j)
    +
    363  vshr1(i,j) = vmean(i,j) - v10(i,j)
    +
    364  ELSE
    +
    365  ushr05(i,j) = 0.0
    +
    366  vshr05(i,j) = 0.0
    +
    367  ushr1(i,j) = 0.0
    +
    368  vshr1(i,j) = 0.0
    +
    369  ENDIF
    +
    370 ! CRA
    +
    371 
    +
    372 !tgs USHR = UMEAN5 - UMEAN1
    +
    373 ! VSHR = VMEAN5 - VMEAN1
    +
    374 
    +
    375 ! UST(I,J) = UMEAN6 + (7.5*VSHR/SQRT(USHR*USHR+VSHR*VSHR))
    +
    376 ! VST(I,J) = VMEAN6 - (7.5*USHR/SQRT(USHR*USHR+VSHR*VSHR))
    +
    377 ! ELSE
    +
    378 ! UST(I,J) = 0.0
    +
    379 ! VST(I,J) = 0.0
    +
    380 ! ENDIF
    +
    381  ENDDO
    +
    382  ENDDO
    +
    383 !
    +
    384 ! COMPUTE STORM-RELATIVE HELICITY
    +
    385 !
    +
    386 !!$omp parallel do private(i,j,n,l,du1,du2,dv1,dv2,dz,dz1,dz2,dzabv,ie,iw,jn,js,z1,z2,z3)
    +
    387  DO l = 2,lm-1
    +
    388  if(gridtype /= 'A')then
    +
    389  call exch(zint(1,jsta_2l,l))
    +
    390  call exch(zint(1,jsta_2l,l+1))
    +
    391  end if
    +
    392  DO j=jstart,jstop
    +
    393  DO i=istart,istop
    +
    394  iw=i+ivw(j)
    +
    395  ie=i+ive(j)
    +
    396  jn=j+jvn
    +
    397  js=j+jvs
    +
    398  IF (gridtype=='B')THEN
    +
    399  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    +
    400  zmid(i,jn,l)+zmid(ie,jn,l))
    +
    401  ELSE
    +
    402  z2=0.25*(zmid(iw,j,l)+zmid(ie,j,l)+ &
    +
    403  zmid(i,jn,l)+zmid(i,js,l))
    +
    404  END IF
    +
    405  dzabv=z2-htsfc(i,j)
    +
    406  elt(i,j) = zint(i,j,lupp(i,j))-htsfc(i,j)
    +
    407  elb(i,j) = zint(i,j,llow(i,j))-htsfc(i,j)
    +
    408 
    +
    409 !
    +
    410  IF(dzabv <= elt(i,j) .AND. dzabv >= elb(i,j) .AND. l <= nint(lmv(i,j)))THEN
    +
    411  IF (gridtype=='B')THEN
    +
    412  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    +
    413  zmid(i,jn,l+1)+zmid(ie,jn,l+1))
    +
    414  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    +
    415  zmid(i,jn,l-1)+zmid(ie,jn,l-1))
    +
    416  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    +
    417  zint(i,jn,l)+zint(ie,jn,l))- &
    +
    418  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    +
    419  zint(i,jn,l+1)+zint(ie,jn,l+1)))
    +
    420  ELSE
    +
    421  z1 = 0.25*(zmid(iw,j,l+1)+zmid(ie,j,l+1)+ &
    +
    422  zmid(i,jn,l+1)+zmid(i,js,l+1))
    +
    423  z3 = 0.25*(zmid(iw,j,l-1)+zmid(ie,j,l-1)+ &
    +
    424  zmid(i,jn,l-1)+zmid(i,js,l-1))
    +
    425  dz = 0.25*((zint(iw,j,l)+zint(ie,j,l)+ &
    +
    426  zint(i,js,l)+zint(i,jn,l))- &
    +
    427  (zint(iw,j,l+1)+zint(ie,j,l+1)+ &
    +
    428  zint(i,js,l+1)+zint(i,jn,l+1)))
    +
    429  END IF
    +
    430  dz1 = z1-z2
    +
    431  dz2 = z2-z3
    +
    432  du1 = uh(i,j,l+1)-uh(i,j,l)
    +
    433  du2 = uh(i,j,l)-uh(i,j,l-1)
    +
    434  dv1 = vh(i,j,l+1)-vh(i,j,l)
    +
    435  dv2 = vh(i,j,l)-vh(i,j,l-1)
    +
    436  IF( l >= lupp(i,j) .AND. l <= llow(i,j) ) THEN
    +
    437  IF( vh(i,j,l) <spval.and.uh(i,j,l) <spval.and. &
    +
    438  vh(i,j,l+1)<spval.and.uh(i,j,l+1)<spval.and. &
    +
    439  vh(i,j,l-1)<spval.and.uh(i,j,l-1)<spval.and. &
    +
    440  vst(i,j) <spval.and.ust(i,j) <spval) &
    +
    441  heli(i,j) = ((vh(i,j,l)-vst(i,j))* &
    +
    442  (dz2*(du1/dz1)+dz1*(du2/dz2)) &
    +
    443  - (uh(i,j,l)-ust(i,j))* &
    +
    444  (dz2*(dv1/dz1)+dz1*(dv2/dz2))) &
    +
    445  *dz/(dz1+dz2)+heli(i,j)
    +
    446  ENDIF
    +
    447  IF(lupp(i,j) == llow(i,j)) heli(i,j) = 0.
    +
    448 
    +
    449 ! if(i==im/2.and.j==(jsta+jend)/2)print*,'Debug Helicity',depth(N),l,dz1,dz2,du1, &
    +
    450 ! du2,dv1,dv2,ust(i,j),vst(i,j)
    +
    451  ENDIF
    +
    452  ENDDO
    +
    453  ENDDO
    +
    454  ENDDO
    +
    455 
    +
    456 ! END OF ROUTINE.
    +
    457 !
    +
    458  RETURN
    +
    459  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    masks
    Definition: MASKS_mod.f:1
    +
    calhel3
    subroutine calhel3(LLOW, LUPP, UST, VST, HELI)
    Subroutine that computes storm relative helicity.
    Definition: CALHEL3.f:56
    params_mod
    Definition: params.F:1
    - +
    lookup_mod
    Definition: LOOKUP.f:1
    @@ -527,7 +531,7 @@
  • sorc
  • ncep_post.fd
  • CALHEL3.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALLCL_8f.html b/CALLCL_8f.html index dbb837d23..784bcb112 100644 --- a/CALLCL_8f.html +++ b/CALLCL_8f.html @@ -3,7 +3,7 @@ - + UPP: CALLCL.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALLCL (P1D, T1D, Q1D, PLCL, ZLCL)
     
    subroutine callcl (P1D, T1D, Q1D, PLCL, ZLCL)
     Subroutine that computes the lifting condensation level (LCL) height (above ground level) and pressure in each column at mass points. More...
     

    Detailed Description

    Subroutine that computes LCL heights and pressure.

    @@ -157,7 +157,68 @@

    Program history log:

    Date
    1993-03-15

    Definition in file CALLCL.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine callcl (real, dimension(ista:iend,jsta:jend), intent(in) P1D,
    real, dimension(ista:iend,jsta:jend), intent(in) T1D,
    real, dimension(ista:iend,jsta:jend), intent(in) Q1D,
    real, dimension(ista:iend,jsta:jend), intent(inout) PLCL,
    real, dimension(ista:iend,jsta:jend), intent(inout) ZLCL 
    )
    +
    + +

    Subroutine that computes the lifting condensation level (LCL) height (above ground level) and pressure in each column at mass points.

    +
    Parameters
    + + + + + + +
    [in]P1DArray of parcel pressures (Pa).
    [in]T1DArray of parcel temperatures (K).
    [in]Q1DArray of parcel specific humidities (kg/kg).
    [out]PLCLParcel Pressure at LCL (Pa).
    [out]ZLCLParcel AGL height at LCL (m).
    +
    +
    + +

    Definition at line 41 of file CALLCL.f.

    + +

    Referenced by miscln().

    + +
    +
    + diff --git a/CALLCL_8f.js b/CALLCL_8f.js index 7461df3cb..dd117ab83 100644 --- a/CALLCL_8f.js +++ b/CALLCL_8f.js @@ -1,4 +1,4 @@ var CALLCL_8f = [ - [ "CALLCL", "CALLCL_8f.html#ab5d92560666c1c9d53e2db53f9478612", null ] + [ "callcl", "CALLCL_8f.html#a24672327249f6cbc1fcc5cf5e6667b8d", null ] ]; \ No newline at end of file diff --git a/CALLCL_8f_source.html b/CALLCL_8f_source.html index a92cb3765..a621ceb5c 100644 --- a/CALLCL_8f_source.html +++ b/CALLCL_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALLCL.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,81 +107,85 @@
    Go to the documentation of this file.
    1 
    -
    31  SUBROUTINE callcl(P1D,T1D,Q1D,PLCL,ZLCL)
    -
    32 
    -
    33 !
    -
    34 !
    -
    35  use vrbls3d, only: alpint, zint
    -
    36  use vrbls2d, only: fis
    -
    37  use masks, only: lmh
    -
    38  use params_mod, only: eps, oneps, d01, h1m12, gi, d00
    -
    39  use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, im, &
    -
    40  ista, iend, ista_m, iend_m
    -
    41 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    42  implicit none
    +
    31 !-----------------------------------------------------------------------
    +
    40 !-----------------------------------------------------------------------
    +
    41  SUBROUTINE callcl(P1D,T1D,Q1D,PLCL,ZLCL)
    +
    42 
    43 !
    -
    44  real,PARAMETER :: d35=3.5, d4805=4.805, h2840=2840.
    -
    45  real,PARAMETER :: h55=55., d2845=0.2845, d28=0.28
    -
    46 !
    -
    47 ! DECLARE VARIABLES.
    -
    48 !
    -
    49  REAL,dimension(ista:iend,jsta:jend), intent(in) :: p1d,t1d,q1d
    -
    50  REAL,dimension(ista:iend,jsta:jend), intent(inout) :: plcl,zlcl
    -
    51  REAL tlcl(ista:iend,jsta:jend)
    -
    52  integer i,j,l,llmh
    -
    53  real dlplcl,zsfc,dz,dalp,alplcl,rmx,evp,arg,rkapa
    -
    54 !
    -
    55 !**********************************************************************
    -
    56 ! START CALLCL HERE.
    -
    57 !
    -
    58 ! LOAD OUTPUT ARRAYS WITH SPECIAL VALUE.
    -
    59 !
    -
    60 !$omp parallel do private(i,j)
    -
    61  DO j=jsta,jend
    -
    62  DO i=ista,iend
    -
    63  plcl(i,j) = spval
    -
    64  tlcl(i,j) = spval
    -
    65  zlcl(i,j) = spval
    -
    66  ENDDO
    -
    67  ENDDO
    -
    68 !
    -
    69 ! COMPUTE PRESSURE, TEMPERATURE AND AGL HEIGHT AT LCL.
    -
    70 !
    -
    71 ! Bo Cui 10/30/2019, remove "GOTO" statement
    -
    72 
    -
    73  DO 30 j=jsta_m,jend_m
    -
    74  DO 30 i=ista_m,iend_m
    -
    75  IF(p1d(i,j)<spval.and.q1d(i,j)<spval)THEN
    -
    76  evp = p1d(i,j)*q1d(i,j)/(eps+oneps*q1d(i,j))
    -
    77  rmx = eps*evp/(p1d(i,j)-evp)
    -
    78  rkapa = 1.0 / (d2845*(1.0-d28*rmx))
    -
    79  arg = max(h1m12,evp*d01)
    -
    80  tlcl(i,j) = h55 + h2840 / (d35*log(t1d(i,j))-log(arg)-d4805)
    -
    81  plcl(i,j) = p1d(i,j)*(tlcl(i,j)/t1d(i,j))**rkapa
    -
    82  alplcl = log(plcl(i,j))
    -
    83  llmh = nint(lmh(i,j))
    -
    84  zsfc = fis(i,j)*gi
    -
    85 !
    -
    86  DO 20 l=llmh,1,-1
    -
    87  IF(alpint(i,j,l) < alplcl)THEN
    -
    88  dlplcl = alplcl - alpint(i,j,l+1)
    -
    89  dalp = alpint(i,j,l) - alpint(i,j,l+1)
    -
    90  dz = zint(i,j,l) - zint(i,j,l+1)
    -
    91  zlcl(i,j) = max(d00, zint(i,j,l+1) + dz*dlplcl/dalp - zsfc)
    -
    92  EXIT
    -
    93  ENDIF
    -
    94  20 CONTINUE
    -
    95  ENDIF
    -
    96  30 CONTINUE
    -
    97 !
    -
    98 ! END OF ROUTINE.
    -
    99 !
    -
    100  RETURN
    -
    101  END
    +
    44 !
    +
    45  use vrbls3d, only: alpint, zint
    +
    46  use vrbls2d, only: fis
    +
    47  use masks, only: lmh
    +
    48  use params_mod, only: eps, oneps, d01, h1m12, gi, d00
    +
    49  use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, im, &
    +
    50  ista, iend, ista_m, iend_m
    +
    51 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    52  implicit none
    +
    53 !
    +
    54  real,PARAMETER :: d35=3.5, d4805=4.805, h2840=2840.
    +
    55  real,PARAMETER :: h55=55., d2845=0.2845, d28=0.28
    +
    56 !
    +
    57 ! DECLARE VARIABLES.
    +
    58 !
    +
    59  REAL,dimension(ista:iend,jsta:jend), intent(in) :: p1d,t1d,q1d
    +
    60  REAL,dimension(ista:iend,jsta:jend), intent(inout) :: plcl,zlcl
    +
    61  REAL tlcl(ista:iend,jsta:jend)
    +
    62  integer i,j,l,llmh
    +
    63  real dlplcl,zsfc,dz,dalp,alplcl,rmx,evp,arg,rkapa
    +
    64 !
    +
    65 !**********************************************************************
    +
    66 ! START CALLCL HERE.
    +
    67 !
    +
    68 ! LOAD OUTPUT ARRAYS WITH SPECIAL VALUE.
    +
    69 !
    +
    70 !$omp parallel do private(i,j)
    +
    71  DO j=jsta,jend
    +
    72  DO i=ista,iend
    +
    73  plcl(i,j) = spval
    +
    74  tlcl(i,j) = spval
    +
    75  zlcl(i,j) = spval
    +
    76  ENDDO
    +
    77  ENDDO
    +
    78 !
    +
    79 ! COMPUTE PRESSURE, TEMPERATURE AND AGL HEIGHT AT LCL.
    +
    80 !
    +
    81 ! Bo Cui 10/30/2019, remove "GOTO" statement
    +
    82 
    +
    83  DO 30 j=jsta_m,jend_m
    +
    84  DO 30 i=ista_m,iend_m
    +
    85  IF(p1d(i,j)<spval.and.q1d(i,j)<spval)THEN
    +
    86  evp = p1d(i,j)*q1d(i,j)/(eps+oneps*q1d(i,j))
    +
    87  rmx = eps*evp/(p1d(i,j)-evp)
    +
    88  rkapa = 1.0 / (d2845*(1.0-d28*rmx))
    +
    89  arg = max(h1m12,evp*d01)
    +
    90  tlcl(i,j) = h55 + h2840 / (d35*log(t1d(i,j))-log(arg)-d4805)
    +
    91  plcl(i,j) = p1d(i,j)*(tlcl(i,j)/t1d(i,j))**rkapa
    +
    92  alplcl = log(plcl(i,j))
    +
    93  llmh = nint(lmh(i,j))
    +
    94  zsfc = fis(i,j)*gi
    +
    95 !
    +
    96  DO 20 l=llmh,1,-1
    +
    97  IF(alpint(i,j,l) < alplcl)THEN
    +
    98  dlplcl = alplcl - alpint(i,j,l+1)
    +
    99  dalp = alpint(i,j,l) - alpint(i,j,l+1)
    +
    100  dz = zint(i,j,l) - zint(i,j,l+1)
    +
    101  zlcl(i,j) = max(d00, zint(i,j,l+1) + dz*dlplcl/dalp - zsfc)
    +
    102  EXIT
    +
    103  ENDIF
    +
    104  20 CONTINUE
    +
    105  ENDIF
    +
    106  30 CONTINUE
    +
    107 !
    +
    108 ! END OF ROUTINE.
    +
    109 !
    +
    110  RETURN
    +
    111  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    masks
    Definition: MASKS_mod.f:1
    params_mod
    Definition: params.F:1
    - + +
    callcl
    subroutine callcl(P1D, T1D, Q1D, PLCL, ZLCL)
    Subroutine that computes the lifting condensation level (LCL) height (above ground level) and pressur...
    Definition: CALLCL.f:41
    @@ -190,7 +194,7 @@
  • sorc
  • ncep_post.fd
  • CALLCL.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALMCVG_8f.html b/CALMCVG_8f.html index 6d0845d16..99d777c94 100644 --- a/CALMCVG_8f.html +++ b/CALMCVG_8f.html @@ -3,7 +3,7 @@ - + UPP: CALMCVG.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALMCVG (Q1D, U1D, V1D, QCNVG)
     
    subroutine calmcvg (Q1D, U1D, V1D, QCNVG)
     Subroutine that computes moisture convergence. More...
     

    Detailed Description

    Subroutine that computes moisture convergence.

    @@ -134,10 +134,10 @@ moisture convergence which is returned by this routine.
    Parameters
    - - - - + + + +
    [in]Q1D- Specific humidity at P-points (kg/kg).
    [in]U1D- U wind component (m/s) at P-points.
    [in]V1D- V wind component (m/s) at P-points.
    [out]QCNVG- Moisture convergence (1/s) at P-points.
    [in]Q1Dreal Specific humidity at P-points (kg/kg).
    [in]U1Dreal U-wind component (m/s) at P-points.
    [in]V1Dreal V-wind component (m/s) at P-points.
    [out]QCNVGreal Moisture convergence (1/s) at P-points.
    @@ -168,7 +168,61 @@

    Program history log:

    Date
    1993-01-22

    Definition in file CALMCVG.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine calmcvg (real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) Q1D,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) U1D,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) V1D,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(inout) QCNVG 
    )
    +
    + +

    Subroutine that computes moisture convergence.

    +
    Parameters
    + + + + + +
    [in]Q1Dreal Specific humidity at P-points (kg/kg).
    [in]U1Dreal U-wind component (m/s) at P-points.
    [in]V1Dreal V-wind component (m/s) at P-points.
    [out]QCNVGreal Moisture convergence (1/s) at P-points.
    +
    +
    + +

    Definition at line 43 of file CALMCVG.f.

    + +

    Referenced by bndlyr(), mdlfld(), and ngmfld().

    + +
    +
    + diff --git a/CALMCVG_8f.js b/CALMCVG_8f.js index 84e00f55d..7f7d63daa 100644 --- a/CALMCVG_8f.js +++ b/CALMCVG_8f.js @@ -1,4 +1,4 @@ var CALMCVG_8f = [ - [ "CALMCVG", "CALMCVG_8f.html#a66aba8ab39d53c73b536b33f00141f17", null ] + [ "calmcvg", "CALMCVG_8f.html#a97bb338486242d59d008a66414a0851d", null ] ]; \ No newline at end of file diff --git a/CALMCVG_8f_source.html b/CALMCVG_8f_source.html index b75ef363f..608df1b39 100644 --- a/CALMCVG_8f_source.html +++ b/CALMCVG_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALMCVG.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,162 +107,166 @@
    Go to the documentation of this file.
    1 
    -
    35  SUBROUTINE calmcvg(Q1D,U1D,V1D,QCNVG)
    -
    36 
    -
    37 !
    -
    38 !
    -
    39 !
    -
    40  use masks, only: dx, dy, hbm2
    -
    41  use params_mod, only: d00, d25
    -
    42  use ctlblk_mod, only: jsta_2l, jend_2u, spval, jsta_m, jend_m, &
    -
    43  jsta_m2, jend_m2, im, jm, &
    -
    44  ista_2l, iend_2u, ista_m, iend_m, ista_m2, iend_m2
    -
    45  use gridspec_mod, only: gridtype
    -
    46 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    47  implicit none
    -
    48 !
    -
    49 ! DECLARE VARIABLES.
    -
    50 !
    -
    51  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: q1d, u1d, v1d
    -
    52  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: qcnvg
    -
    53 
    -
    54  REAL r2dy, r2dx
    -
    55  REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: uwnd, vwnd, qv
    -
    56  INTEGER ihe(jm),ihw(jm),ive(jm),ivw(jm)
    -
    57  integer i,j,ista2,iend2
    -
    58  real qvdy,qudx
    -
    59 !
    -
    60 !***************************************************************************
    -
    61 ! START CALMCVG HERE.
    -
    62 !
    -
    63 !
    -
    64 ! INITIALIZE MOISTURE CONVERGENCE ARRAY. LOAD TEMPORARY WIND ARRAYS.
    -
    65 !
    -
    66  CALL exch(q1d)
    -
    67  CALL exch(u1d)
    -
    68  CALL exch(v1d)
    -
    69 
    -
    70 !$omp parallel do private(i,j)
    -
    71  DO j=jsta_2l,jend_2u
    -
    72 ! DO I=1,IM
    -
    73  DO i=ista_2l,iend_2u
    -
    74  IF(u1d(i,j)<spval)THEN
    -
    75  qcnvg(i,j) = 0.
    -
    76  ELSE
    -
    77  qcnvg(i,j) = spval
    -
    78  ENDIF
    -
    79  uwnd(i,j) = u1d(i,j)
    -
    80  vwnd(i,j) = v1d(i,j)
    -
    81  IF (uwnd(i,j) == spval) uwnd(i,j) = d00
    -
    82  IF (vwnd(i,j) == spval) vwnd(i,j) = d00
    -
    83  ENDDO
    -
    84  ENDDO
    -
    85 !
    -
    86  IF(gridtype == 'A')THEN
    -
    87 !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy)
    -
    88  DO j=jsta_m,jend_m
    -
    89 ! DO I=2,IM-1
    -
    90  DO i=ista_m,iend_m
    -
    91  IF(q1d(i,j+1)<spval.AND.q1d(i,j-1)<spval.AND. &
    -
    92  q1d(i+1,j)<spval.AND.q1d(i-1,j)<spval.AND. &
    -
    93  q1d(i,j)<spval) THEN
    -
    94  r2dx = 1./(2.*dx(i,j)) !MEB DX?
    -
    95  r2dy = 1./(2.*dy(i,j)) !MEB DY?
    -
    96  qudx = (q1d(i+1,j)*uwnd(i+1,j)-q1d(i-1,j)*uwnd(i-1,j))*r2dx
    -
    97  qvdy = (q1d(i,j+1)*vwnd(i,j+1)-q1d(i,j-1)*vwnd(i,j-1))*r2dy
    -
    98  qcnvg(i,j) = -(qudx + qvdy)
    -
    99  ELSE
    -
    100  qcnvg(i,j) = spval
    -
    101  ENDIF
    -
    102  ENDDO
    -
    103  ENDDO
    -
    104  ELSE IF(gridtype == 'E')THEN
    -
    105 
    -
    106  DO j=jsta_m,jend_m
    -
    107  ihe(j) = mod(j+1,2)
    -
    108  ihw(j) = ihe(j)-1
    -
    109  ive(j) = mod(j,2)
    -
    110  ivw(j) = ive(j)-1
    -
    111  END DO
    -
    112 
    -
    113 !$omp parallel do private(i,j)
    +
    35 !-----------------------------------------------------------------------
    +
    42 !-----------------------------------------------------------------------
    +
    43  SUBROUTINE calmcvg(Q1D,U1D,V1D,QCNVG)
    +
    44 
    +
    45 !
    +
    46 !
    +
    47 !
    +
    48  use masks, only: dx, dy, hbm2
    +
    49  use params_mod, only: d00, d25
    +
    50  use ctlblk_mod, only: jsta_2l, jend_2u, spval, jsta_m, jend_m, &
    +
    51  jsta_m2, jend_m2, im, jm, &
    +
    52  ista_2l, iend_2u, ista_m, iend_m, ista_m2, iend_m2
    +
    53  use gridspec_mod, only: gridtype
    +
    54 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    55  implicit none
    +
    56 !
    +
    57 ! DECLARE VARIABLES.
    +
    58 !
    +
    59  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: q1d, u1d, v1d
    +
    60  REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: qcnvg
    +
    61 
    +
    62  REAL r2dy, r2dx
    +
    63  REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: uwnd, vwnd, qv
    +
    64  INTEGER ihe(jm),ihw(jm),ive(jm),ivw(jm)
    +
    65  integer i,j,ista2,iend2
    +
    66  real qvdy,qudx
    +
    67 !
    +
    68 !***************************************************************************
    +
    69 ! START CALMCVG HERE.
    +
    70 !
    +
    71 !
    +
    72 ! INITIALIZE MOISTURE CONVERGENCE ARRAY. LOAD TEMPORARY WIND ARRAYS.
    +
    73 !
    +
    74  CALL exch(q1d)
    +
    75  CALL exch(u1d)
    +
    76  CALL exch(v1d)
    +
    77 
    +
    78 !$omp parallel do private(i,j)
    +
    79  DO j=jsta_2l,jend_2u
    +
    80 ! DO I=1,IM
    +
    81  DO i=ista_2l,iend_2u
    +
    82  IF(u1d(i,j)<spval)THEN
    +
    83  qcnvg(i,j) = 0.
    +
    84  ELSE
    +
    85  qcnvg(i,j) = spval
    +
    86  ENDIF
    +
    87  uwnd(i,j) = u1d(i,j)
    +
    88  vwnd(i,j) = v1d(i,j)
    +
    89  IF (uwnd(i,j) == spval) uwnd(i,j) = d00
    +
    90  IF (vwnd(i,j) == spval) vwnd(i,j) = d00
    +
    91  ENDDO
    +
    92  ENDDO
    +
    93 !
    +
    94  IF(gridtype == 'A')THEN
    +
    95 !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy)
    +
    96  DO j=jsta_m,jend_m
    +
    97 ! DO I=2,IM-1
    +
    98  DO i=ista_m,iend_m
    +
    99  IF(q1d(i,j+1)<spval.AND.q1d(i,j-1)<spval.AND. &
    +
    100  q1d(i+1,j)<spval.AND.q1d(i-1,j)<spval.AND. &
    +
    101  q1d(i,j)<spval) THEN
    +
    102  r2dx = 1./(2.*dx(i,j)) !MEB DX?
    +
    103  r2dy = 1./(2.*dy(i,j)) !MEB DY?
    +
    104  qudx = (q1d(i+1,j)*uwnd(i+1,j)-q1d(i-1,j)*uwnd(i-1,j))*r2dx
    +
    105  qvdy = (q1d(i,j+1)*vwnd(i,j+1)-q1d(i,j-1)*vwnd(i,j-1))*r2dy
    +
    106  qcnvg(i,j) = -(qudx + qvdy)
    +
    107  ELSE
    +
    108  qcnvg(i,j) = spval
    +
    109  ENDIF
    +
    110  ENDDO
    +
    111  ENDDO
    +
    112  ELSE IF(gridtype == 'E')THEN
    +
    113 
    114  DO j=jsta_m,jend_m
    -
    115 ! ISTA = 1+MOD(J+1,2)
    -
    116 ! IEND = IM-MOD(J,2)
    -
    117 ! DO I=ISTA,IEND
    -
    118  DO i=ista_m,iend_m
    -
    119  IF(q1d(i,j-1)<spval.AND.q1d(i+ivw(j),j)<spval.AND.&
    -
    120  q1d(i+ive(j),j)<spval.AND.q1d(i,j+1)<spval) THEN
    -
    121  qv(i,j) = d25*(q1d(i,j-1)+q1d(i+ivw(j),j) &
    -
    122  +q1d(i+ive(j),j)+q1d(i,j+1))
    -
    123  ELSE
    -
    124  qv(i,j) = spval
    -
    125  ENDIF
    -
    126  END DO
    -
    127  END DO
    -
    128 
    -
    129  CALL exch(qv)
    -
    130 ! CALL EXCH(VWND)
    -
    131 
    -
    132 !
    -
    133 !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy)
    -
    134  DO j=jsta_m2,jend_m2
    -
    135 ! IEND = IM-1-MOD(J,2)
    -
    136 ! DO I=2,IEND
    -
    137  DO i=ista_m,iend_m-mod(j,2)
    -
    138  IF(qv(i+ihe(j),j)<spval.AND.uwnd(i+ihe(j),j)<spval.AND.&
    -
    139  qv(i+ihw(j),j)<spval.AND.uwnd(i+ihw(j),j)<spval.AND.&
    -
    140  qv(i,j)<spval.AND.qv(i,j-1)<spval.AND.qv(i,j+1)<spval) THEN
    -
    141  r2dx = 1./(2.*dx(i,j))
    -
    142  r2dy = 1./(2.*dy(i,j))
    -
    143  qudx = (qv(i+ihe(j),j)*uwnd(i+ihe(j),j) &
    -
    144  -qv(i+ihw(j),j)*uwnd(i+ihw(j),j))*r2dx
    -
    145  qvdy = (qv(i,j+1)*vwnd(i,j+1)-qv(i,j-1)*vwnd(i,j-1))*r2dy
    -
    146 
    -
    147  qcnvg(i,j) = -(qudx + qvdy) * hbm2(i,j)
    -
    148  ELSE
    -
    149  qcnvg(i,j) = spval
    -
    150  ENDIF
    -
    151  ENDDO
    -
    152  ENDDO
    -
    153  ELSE IF(gridtype=='B')THEN
    -
    154 
    -
    155 ! CALL EXCH(UWND)
    -
    156 !
    -
    157 !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy)
    -
    158  DO j=jsta_m,jend_m
    -
    159 ! DO I=2,IM-1
    -
    160  DO i=ista_m,iend_m
    -
    161  IF(uwnd(i,j)<spval.AND.uwnd(i,j-1)<spval.AND.&
    -
    162  uwnd(i-1,j)<spval.AND.uwnd(i-1,j-1)<spval.AND.&
    -
    163  q1d(i,j)<spval.AND.q1d(i+1,j)<spval.AND.q1d(i-1,j)<spval.AND.&
    -
    164  vwnd(i,j)<spval.AND.vwnd(i-1,j)<spval.AND.&
    -
    165  vwnd(i,j-1)<spval.AND.vwnd(i-1,j-1)<spval.AND.&
    -
    166  q1d(i,j+1)<spval.AND.q1d(i,j-1)<spval) THEN
    -
    167  r2dx = 1./dx(i,j)
    -
    168  r2dy = 1./dy(i,j)
    -
    169  qudx=(0.5*(uwnd(i,j)+uwnd(i,j-1))*0.5*(q1d(i,j)+q1d(i+1,j)) &
    -
    170  -0.5*(uwnd(i-1,j)+uwnd(i-1,j-1))*0.5*(q1d(i,j)+q1d(i-1,j)))*r2dx
    -
    171  qvdy=(0.5*(vwnd(i,j)+vwnd(i-1,j))*0.5*(q1d(i,j)+q1d(i,j+1)) &
    -
    172  -0.5*(vwnd(i,j-1)+vwnd(i-1,j-1))*0.5*(q1d(i,j)+q1d(i,j-1)))*r2dy
    -
    173 
    -
    174  qcnvg(i,j) = -(qudx + qvdy)
    -
    175  ELSE
    -
    176  qcnvg(i,j) = spval
    -
    177  ENDIF
    -
    178 ! print*,'mcvg=',i,j,r2dx,r2dy,QCNVG(I,J)
    -
    179  ENDDO
    -
    180  ENDDO
    -
    181  ENDIF
    -
    182 !meb not sure about the indexing for the c-grid
    -
    183 !
    -
    184 ! END OF ROUTINE.
    -
    185 !
    -
    186  RETURN
    -
    187  END
    -
    188 
    +
    115  ihe(j) = mod(j+1,2)
    +
    116  ihw(j) = ihe(j)-1
    +
    117  ive(j) = mod(j,2)
    +
    118  ivw(j) = ive(j)-1
    +
    119  END DO
    +
    120 
    +
    121 !$omp parallel do private(i,j)
    +
    122  DO j=jsta_m,jend_m
    +
    123 ! ISTA = 1+MOD(J+1,2)
    +
    124 ! IEND = IM-MOD(J,2)
    +
    125 ! DO I=ISTA,IEND
    +
    126  DO i=ista_m,iend_m
    +
    127  IF(q1d(i,j-1)<spval.AND.q1d(i+ivw(j),j)<spval.AND.&
    +
    128  q1d(i+ive(j),j)<spval.AND.q1d(i,j+1)<spval) THEN
    +
    129  qv(i,j) = d25*(q1d(i,j-1)+q1d(i+ivw(j),j) &
    +
    130  +q1d(i+ive(j),j)+q1d(i,j+1))
    +
    131  ELSE
    +
    132  qv(i,j) = spval
    +
    133  ENDIF
    +
    134  END DO
    +
    135  END DO
    +
    136 
    +
    137  CALL exch(qv)
    +
    138 ! CALL EXCH(VWND)
    +
    139 
    +
    140 !
    +
    141 !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy)
    +
    142  DO j=jsta_m2,jend_m2
    +
    143 ! IEND = IM-1-MOD(J,2)
    +
    144 ! DO I=2,IEND
    +
    145  DO i=ista_m,iend_m-mod(j,2)
    +
    146  IF(qv(i+ihe(j),j)<spval.AND.uwnd(i+ihe(j),j)<spval.AND.&
    +
    147  qv(i+ihw(j),j)<spval.AND.uwnd(i+ihw(j),j)<spval.AND.&
    +
    148  qv(i,j)<spval.AND.qv(i,j-1)<spval.AND.qv(i,j+1)<spval) THEN
    +
    149  r2dx = 1./(2.*dx(i,j))
    +
    150  r2dy = 1./(2.*dy(i,j))
    +
    151  qudx = (qv(i+ihe(j),j)*uwnd(i+ihe(j),j) &
    +
    152  -qv(i+ihw(j),j)*uwnd(i+ihw(j),j))*r2dx
    +
    153  qvdy = (qv(i,j+1)*vwnd(i,j+1)-qv(i,j-1)*vwnd(i,j-1))*r2dy
    +
    154 
    +
    155  qcnvg(i,j) = -(qudx + qvdy) * hbm2(i,j)
    +
    156  ELSE
    +
    157  qcnvg(i,j) = spval
    +
    158  ENDIF
    +
    159  ENDDO
    +
    160  ENDDO
    +
    161  ELSE IF(gridtype=='B')THEN
    +
    162 
    +
    163 ! CALL EXCH(UWND)
    +
    164 !
    +
    165 !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy)
    +
    166  DO j=jsta_m,jend_m
    +
    167 ! DO I=2,IM-1
    +
    168  DO i=ista_m,iend_m
    +
    169  IF(uwnd(i,j)<spval.AND.uwnd(i,j-1)<spval.AND.&
    +
    170  uwnd(i-1,j)<spval.AND.uwnd(i-1,j-1)<spval.AND.&
    +
    171  q1d(i,j)<spval.AND.q1d(i+1,j)<spval.AND.q1d(i-1,j)<spval.AND.&
    +
    172  vwnd(i,j)<spval.AND.vwnd(i-1,j)<spval.AND.&
    +
    173  vwnd(i,j-1)<spval.AND.vwnd(i-1,j-1)<spval.AND.&
    +
    174  q1d(i,j+1)<spval.AND.q1d(i,j-1)<spval) THEN
    +
    175  r2dx = 1./dx(i,j)
    +
    176  r2dy = 1./dy(i,j)
    +
    177  qudx=(0.5*(uwnd(i,j)+uwnd(i,j-1))*0.5*(q1d(i,j)+q1d(i+1,j)) &
    +
    178  -0.5*(uwnd(i-1,j)+uwnd(i-1,j-1))*0.5*(q1d(i,j)+q1d(i-1,j)))*r2dx
    +
    179  qvdy=(0.5*(vwnd(i,j)+vwnd(i-1,j))*0.5*(q1d(i,j)+q1d(i,j+1)) &
    +
    180  -0.5*(vwnd(i,j-1)+vwnd(i-1,j-1))*0.5*(q1d(i,j)+q1d(i,j-1)))*r2dy
    +
    181 
    +
    182  qcnvg(i,j) = -(qudx + qvdy)
    +
    183  ELSE
    +
    184  qcnvg(i,j) = spval
    +
    185  ENDIF
    +
    186 ! print*,'mcvg=',i,j,r2dx,r2dy,QCNVG(I,J)
    +
    187  ENDDO
    +
    188  ENDDO
    +
    189  ENDIF
    +
    190 !meb not sure about the indexing for the c-grid
    +
    191 !
    +
    192 ! END OF ROUTINE.
    +
    193 !
    +
    194  RETURN
    +
    195  END
    +
    196 
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    masks
    Definition: MASKS_mod.f:1
    params_mod
    Definition: params.F:1
    +
    calmcvg
    subroutine calmcvg(Q1D, U1D, V1D, QCNVG)
    Subroutine that computes moisture convergence.
    Definition: CALMCVG.f:43
    @@ -271,7 +275,7 @@
  • sorc
  • ncep_post.fd
  • CALMCVG.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALPOT_8f.html b/CALPOT_8f.html index eac9d6da0..8111ff1fe 100644 --- a/CALPOT_8f.html +++ b/CALPOT_8f.html @@ -3,7 +3,7 @@ - + UPP: CALPOT.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALPOT (P1D, T1D, THETA)
     
    subroutine calpot (P1D, T1D, THETA)
     Subroutine that computes potential temperature. More...
     

    Detailed Description

    Subroutine that computes potential temperature.

    @@ -150,7 +150,54 @@

    Program history log:

    Date
    1992-12-24

    Definition in file CALPOT.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine calpot (real, dimension(ista:iend,jsta:jend), intent(in) P1D,
    real, dimension(ista:iend,jsta:jend), intent(in) T1D,
    real, dimension(ista:iend,jsta:jend), intent(inout) THETA 
    )
    +
    + +

    Subroutine that computes potential temperature.

    +
    Parameters
    + + + + +
    [in]P1Dpressures (Pa).
    [in]T1Dtemperatures (K).
    [out]THETApotential temperatures (K).
    +
    +
    + +

    Definition at line 28 of file CALPOT.f.

    + +

    Referenced by mdlfld(), and miscln().

    + +
    +
    + diff --git a/CALPOT_8f.js b/CALPOT_8f.js index d740bfc7e..42ab69cf5 100644 --- a/CALPOT_8f.js +++ b/CALPOT_8f.js @@ -1,4 +1,4 @@ var CALPOT_8f = [ - [ "CALPOT", "CALPOT_8f.html#a954efff45bd0fed453f82aecd2ea0138", null ] + [ "calpot", "CALPOT_8f.html#adf98b6aae237d143332a653f9e020c66", null ] ]; \ No newline at end of file diff --git a/CALPOT_8f_source.html b/CALPOT_8f_source.html index 33972bde4..8138ee269 100644 --- a/CALPOT_8f_source.html +++ b/CALPOT_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALPOT.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,53 +107,57 @@
    Go to the documentation of this file.
    1 
    -
    21  SUBROUTINE calpot(P1D,T1D,THETA)
    -
    22 
    -
    23 !
    -
    24  use ctlblk_mod, only: jsta, jend, spval, im, ista, iend
    -
    25 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    26  implicit none
    -
    27 !
    -
    28 ! SET REQUIRED CONSTANTS.
    -
    29  real,PARAMETER :: capa=0.28589641,p1000=1000.e2
    -
    30 !
    -
    31 ! DECLARE VARIABLES.
    -
    32 !
    -
    33  real,dimension(ista:iend,jsta:jend),intent(in) :: p1d,t1d
    -
    34  real,dimension(ista:iend,jsta:jend),intent(inout) :: theta
    -
    35 
    -
    36  integer i,j
    -
    37 !
    -
    38 !**********************************************************************
    -
    39 ! START CALPOT HERE.
    -
    40 !
    -
    41 ! COMPUTE THETA
    -
    42 !
    -
    43 !$omp parallel do private(i,j)
    -
    44  DO j=jsta,jend
    -
    45  DO i=ista,iend
    -
    46  IF(t1d(i,j) < spval) THEN
    -
    47 ! IF(ABS(P1D(I,J)) > 1.0) THEN
    -
    48  IF(p1d(i,j) > 1.0) THEN
    -
    49  theta(i,j) = t1d(i,j) * (p1000/p1d(i,j))**capa
    -
    50  ELSE
    -
    51  theta(i,j) = 0.0
    -
    52  ENDIF
    -
    53  ELSE
    -
    54  theta(i,j) = spval
    -
    55  ENDIF
    -
    56  ENDDO
    -
    57  ENDDO
    -
    58 ! do j = 180, 185
    -
    59 ! print *, ' me, j, p1d,t1d,theta = ',
    -
    60 ! * me, j, p1d(10,j),t1d(10,j),theta (10,j)
    -
    61 ! end do
    -
    62 ! stop
    -
    63 !
    -
    64 ! END OF ROUTINE.
    -
    65 !
    -
    66  RETURN
    -
    67  END
    +
    21 !-----------------------------------------------------------------------
    +
    27 !-----------------------------------------------------------------------
    +
    28  SUBROUTINE calpot(P1D,T1D,THETA)
    +
    29 
    +
    30 !
    +
    31  use ctlblk_mod, only: jsta, jend, spval, im, ista, iend
    +
    32 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    33  implicit none
    +
    34 !
    +
    35 ! SET REQUIRED CONSTANTS.
    +
    36  real,PARAMETER :: capa=0.28589641,p1000=1000.e2
    +
    37 !
    +
    38 ! DECLARE VARIABLES.
    +
    39 !
    +
    40  real,dimension(ista:iend,jsta:jend),intent(in) :: p1d,t1d
    +
    41  real,dimension(ista:iend,jsta:jend),intent(inout) :: theta
    +
    42 
    +
    43  integer i,j
    +
    44 !
    +
    45 !**********************************************************************
    +
    46 ! START CALPOT HERE.
    +
    47 !
    +
    48 ! COMPUTE THETA
    +
    49 !
    +
    50 !$omp parallel do private(i,j)
    +
    51  DO j=jsta,jend
    +
    52  DO i=ista,iend
    +
    53  IF(t1d(i,j) < spval) THEN
    +
    54 ! IF(ABS(P1D(I,J)) > 1.0) THEN
    +
    55  IF(p1d(i,j) > 1.0) THEN
    +
    56  theta(i,j) = t1d(i,j) * (p1000/p1d(i,j))**capa
    +
    57  ELSE
    +
    58  theta(i,j) = 0.0
    +
    59  ENDIF
    +
    60  ELSE
    +
    61  theta(i,j) = spval
    +
    62  ENDIF
    +
    63  ENDDO
    +
    64  ENDDO
    +
    65 ! do j = 180, 185
    +
    66 ! print *, ' me, j, p1d,t1d,theta = ',
    +
    67 ! * me, j, p1d(10,j),t1d(10,j),theta (10,j)
    +
    68 ! end do
    +
    69 ! stop
    +
    70 !
    +
    71 ! END OF ROUTINE.
    +
    72 !
    +
    73  RETURN
    +
    74  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    +
    calpot
    subroutine calpot(P1D, T1D, THETA)
    Subroutine that computes potential temperature.
    Definition: CALPOT.f:28
    @@ -162,7 +166,7 @@
  • sorc
  • ncep_post.fd
  • CALPOT.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALRCH_8f.html b/CALRCH_8f.html index a04b9a622..4cfe0e657 100644 --- a/CALRCH_8f.html +++ b/CALRCH_8f.html @@ -3,7 +3,7 @@ - + UPP: CALRCH.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALRCH (EL, RICHNO)
     
    subroutine calrch (EL, RICHNO)
     Subroutine that computes GRD RCH number. More...
     

    Detailed Description

    Subroutine that computes GRD RCH number.

    @@ -155,7 +155,47 @@

    Program history log:

    Date
    1993-10-11

    Definition in file CALRCH.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine calrch (real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(in) EL,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(inout) RICHNO 
    )
    +
    + +

    Subroutine that computes GRD RCH number.

    +
    Parameters
    + + + +
    [in]ELMixing length scale.
    [out]RICHNOGradient Richardson number.
    +
    +
    + +

    Definition at line 31 of file CALRCH.f.

    + +

    Referenced by mdlfld().

    + +
    +
    + diff --git a/CALRCH_8f.js b/CALRCH_8f.js index 90f6dfa58..f6757df73 100644 --- a/CALRCH_8f.js +++ b/CALRCH_8f.js @@ -1,4 +1,4 @@ var CALRCH_8f = [ - [ "CALRCH", "CALRCH_8f.html#ab42affdb2969cce1774c627a58a84012", null ] + [ "calrch", "CALRCH_8f.html#a51e1e92941beab0973e25c79f9cc1802", null ] ]; \ No newline at end of file diff --git a/CALRCH_8f_source.html b/CALRCH_8f_source.html index 5ac24b593..81bc68a76 100644 --- a/CALRCH_8f_source.html +++ b/CALRCH_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALRCH.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,159 +107,164 @@
    Go to the documentation of this file.
    1 
    -
    24  SUBROUTINE calrch(EL,RICHNO)
    -
    25 
    -
    26 !
    -
    27  use vrbls3d, only: pmid, q, t, uh, vh, zmid, q2
    -
    28  use masks, only: vtm
    -
    29  use params_mod, only: h10e5, capa, d608,h1, epsq2, g, beta
    -
    30  use ctlblk_mod, only: jsta, jend, spval, lm1, jsta_m, jend_m, im, &
    -
    31  jsta_2l, jend_2u, lm, &
    -
    32  ista, iend, ista_m, iend_m, ista_2l, iend_2u
    -
    33  use gridspec_mod, only: gridtype
    -
    34 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    35  implicit none
    -
    36 !
    -
    37 ! DECLARE VARIABLES.
    -
    38 !
    -
    39  REAL,intent(in) :: el(ista_2l:iend_2u,jsta_2l:jend_2u,lm)
    -
    40  REAL,intent(inout) :: richno(ista_2l:iend_2u,jsta_2l:jend_2u,lm)
    -
    41 !
    -
    42  REAL, ALLOCATABLE :: thv(:,:,:)
    -
    43  integer i,j,l,iw,ie
    -
    44  real ape,uhkl,ulkl,vhkl,vlkl,wndsl,wndslp,rdzkl, &
    -
    45  dthvkl,dukl,dvkl,ri,ct,cs
    -
    46 ! real APE,UHKL,ULKL,VHKL,VLKL,WNDSL,WNDSLP,DZKL,RDZKL,Q2KL,QROOT,ELKL, &
    -
    47 ! ELKLSQ,DTHVKL,DUKL,DVKL,RI,CT,CS
    +
    24 !-----------------------------------------------------------------------
    +
    29 !-----------------------------------------------------------------------
    +
    30 
    +
    31  SUBROUTINE calrch(EL,RICHNO)
    +
    32 
    +
    33 !
    +
    34  use vrbls3d, only: pmid, q, t, uh, vh, zmid, q2
    +
    35  use masks, only: vtm
    +
    36  use params_mod, only: h10e5, capa, d608,h1, epsq2, g, beta
    +
    37  use ctlblk_mod, only: jsta, jend, spval, lm1, jsta_m, jend_m, im, &
    +
    38  jsta_2l, jend_2u, lm, &
    +
    39  ista, iend, ista_m, iend_m, ista_2l, iend_2u
    +
    40  use gridspec_mod, only: gridtype
    +
    41 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    42  implicit none
    +
    43 !
    +
    44 ! DECLARE VARIABLES.
    +
    45 !
    +
    46  REAL,intent(in) :: el(ista_2l:iend_2u,jsta_2l:jend_2u,lm)
    +
    47  REAL,intent(inout) :: richno(ista_2l:iend_2u,jsta_2l:jend_2u,lm)
    48 !
    -
    49 !
    -
    50 !*************************************************************************
    -
    51 ! START CALRCH HERE.
    -
    52 !
    -
    53  ALLOCATE ( thv(ista_2l:iend_2u,jsta_2l:jend_2u,lm) )
    -
    54 ! INITIALIZE ARRAYS.
    -
    55 !
    -
    56 !$omp parallel do
    -
    57  DO l = 1,lm
    -
    58  DO j=jsta,jend
    -
    59  DO i=ista,iend
    -
    60  richno(i,j,l)=spval
    -
    61  ENDDO
    -
    62  ENDDO
    -
    63  ENDDO
    -
    64 !
    -
    65 ! COMPUTE VIRTUAL POTENTIAL TEMPERATURE.
    -
    66 !
    -
    67 !$omp parallel do private(i,j,ape)
    -
    68  DO l=lm,1,-1
    -
    69  DO j=jsta,jend
    -
    70  DO i=ista,iend
    -
    71  ape = (h10e5/pmid(i,j,l))**capa
    -
    72  thv(i,j,l) = (q(i,j,l)*d608+h1)*t(i,j,l)*ape
    -
    73  ENDDO
    -
    74  ENDDO
    -
    75  ENDDO
    -
    76 !
    -
    77 ! COMPUTE GRADIENT RICHARDSON NUMBER AS CODED IN ETA MODEL
    -
    78 ! SUBROUTINE PROFQ2.F. OUTER LOOP OVER THE VERTICAL.
    -
    79 ! INTTER LOOP OVER THE HORIZONTAL.
    -
    80 !
    -
    81 !!$omp parallel do private(i,j,l,ie,iw,cs,ct,dthvkl,dukl,dvkl, &
    -
    82 !!$omp& rdzkl,ri,uhkl,ulkl,vhkl,vlkl,wndsl,wndslp)
    -
    83  DO l = 1,lm1
    -
    84 !
    -
    85  if(gridtype /= 'A')THEN
    -
    86  call exch(vtm(1,jsta_2l,l))
    -
    87  call exch(uh(1,jsta_2l,l))
    -
    88  call exch(vh(1,jsta_2l,l))
    -
    89  call exch(vtm(1,jsta_2l,l+1))
    -
    90  call exch(uh(1,jsta_2l,l+1))
    -
    91  call exch(vh(1,jsta_2l,l+1))
    -
    92  end if
    -
    93 
    -
    94  DO j=jsta_m,jend_m
    -
    95  DO i=ista_m,iend_m
    -
    96 !
    -
    97  IF(gridtype == 'A')THEN
    -
    98  uhkl = uh(i,j,l)
    -
    99  ulkl = uh(i,j,l+1)
    -
    100  vhkl = vh(i,j,l)
    -
    101  vlkl = vh(i,j,l+1)
    -
    102  ELSE IF(gridtype == 'E')THEN
    -
    103  ie = i+mod(j+1,2)
    -
    104  iw = i+mod(j+1,2)-1
    -
    105 !
    -
    106 ! WE NEED (U,V) WINDS AT A MASS POINT. FOUR POINT
    -
    107 ! AVERAGE (U,V) WINDS TO MASS POINT. NORMALIZE FOUR
    -
    108 ! POINT AVERAGE BY THE ACTUAL NUMBER OF (U,V) WINDS
    -
    109 ! USED IN THE AVERAGING. VTM=1 IF WIND POINT IS
    -
    110 ! ABOVE GROUND. VTM=0 IF BELOW GROUND.
    -
    111 !
    -
    112  wndsl = vtm(i,j-1,l)+vtm(iw,j,l)+vtm(ie,j,l)+vtm(i,j+1,l)
    -
    113  wndslp = vtm(i,j-1,l+1) + vtm(iw,j,l+1)+ &
    -
    114  vtm(ie,j,l+1) + vtm(i,j+1,l+1)
    -
    115  IF(wndsl == 0. .OR. wndslp == 0.) cycle
    -
    116  uhkl = (uh(i,j-1,l)+uh(iw,j,l)+uh(ie,j,l)+uh(i,j+1,l))/wndsl
    -
    117  ulkl = (uh(i,j-1,l+1)+uh(iw,j,l+1)+uh(ie,j,l+1)+ &
    -
    118  uh(i,j+1,l+1))/wndslp
    -
    119  vhkl = (vh(i,j-1,l)+vh(iw,j,l)+vh(ie,j,l)+vh(i,j+1,l))/wndsl
    -
    120  vlkl = (vh(i,j-1,l+1)+vh(iw,j,l+1)+vh(ie,j,l+1)+ &
    -
    121  vh(i,j+1,l+1))/wndslp
    -
    122  ELSE IF(gridtype == 'B')THEN
    -
    123  ie = i
    -
    124  iw = i-1
    -
    125  uhkl = (uh(iw,j-1,l)+uh(iw,j,l)+uh(ie,j-1,l)+uh(i,j,l))/4.0
    -
    126  ulkl = (uh(iw,j-1,l+1)+uh(iw,j,l+1)+uh(ie,j-1,l+1)+ &
    -
    127  uh(i,j,l+1))/4.0
    -
    128  vhkl = (vh(iw,j-1,l)+vh(iw,j,l)+vh(ie,j-1,l)+vh(i,j,l))/4.0
    -
    129  vlkl = (vh(iw,j-1,l+1)+vh(iw,j,l+1)+vh(ie,j-1,l+1)+ &
    -
    130  vh(i,j,l+1))/4.0
    -
    131  END IF
    -
    132 
    -
    133  rdzkl = 1.0 / (zmid(i,j,l)-zmid(i,j,l+1))
    -
    134 
    -
    135 ! Q2KL = MAX(Q2(I,J,L),0.00001)
    -
    136 ! QROOT = SQRT(Q2KL)
    -
    137 ! ELKL = EL(I,J,L)
    -
    138 ! ELKL = MAX(ELKL,EPSQ2)
    -
    139 ! ELKLSQ = ELKL*ELKL
    -
    140 
    -
    141  dthvkl = thv(i,j,l)-thv(i,j,l+1)
    -
    142  dukl = (uhkl-ulkl) * rdzkl
    -
    143  dvkl = (vhkl-vlkl) * rdzkl
    -
    144  cs = dukl*dukl + dvkl*dvkl
    -
    145 !
    -
    146 ! COMPUTE GRADIENT RICHARDSON NUMBER.
    -
    147 !
    -
    148  IF(cs <= 1.e-8) THEN
    -
    149 !
    -
    150 ! WIND SHEAR IS VANISHINGLY SMALL - SO SET RICHARDSON
    -
    151 ! NUMBER TO POST PROCESSOR SPECIAL VALUE.
    -
    152 !
    -
    153  richno(i,j,l) = spval
    -
    154 !
    -
    155  ELSE
    +
    49  REAL, ALLOCATABLE :: thv(:,:,:)
    +
    50  integer i,j,l,iw,ie
    +
    51  real ape,uhkl,ulkl,vhkl,vlkl,wndsl,wndslp,rdzkl, &
    +
    52  dthvkl,dukl,dvkl,ri,ct,cs
    +
    53 ! real APE,UHKL,ULKL,VHKL,VLKL,WNDSL,WNDSLP,DZKL,RDZKL,Q2KL,QROOT,ELKL, &
    +
    54 ! ELKLSQ,DTHVKL,DUKL,DVKL,RI,CT,CS
    +
    55 !
    +
    56 !
    +
    57 !*************************************************************************
    +
    58 ! START CALRCH HERE.
    +
    59 !
    +
    60  ALLOCATE ( thv(ista_2l:iend_2u,jsta_2l:jend_2u,lm) )
    +
    61 ! INITIALIZE ARRAYS.
    +
    62 !
    +
    63 !$omp parallel do
    +
    64  DO l = 1,lm
    +
    65  DO j=jsta,jend
    +
    66  DO i=ista,iend
    +
    67  richno(i,j,l)=spval
    +
    68  ENDDO
    +
    69  ENDDO
    +
    70  ENDDO
    +
    71 !
    +
    72 ! COMPUTE VIRTUAL POTENTIAL TEMPERATURE.
    +
    73 !
    +
    74 !$omp parallel do private(i,j,ape)
    +
    75  DO l=lm,1,-1
    +
    76  DO j=jsta,jend
    +
    77  DO i=ista,iend
    +
    78  ape = (h10e5/pmid(i,j,l))**capa
    +
    79  thv(i,j,l) = (q(i,j,l)*d608+h1)*t(i,j,l)*ape
    +
    80  ENDDO
    +
    81  ENDDO
    +
    82  ENDDO
    +
    83 !
    +
    84 ! COMPUTE GRADIENT RICHARDSON NUMBER AS CODED IN ETA MODEL
    +
    85 ! SUBROUTINE PROFQ2.F. OUTER LOOP OVER THE VERTICAL.
    +
    86 ! INTTER LOOP OVER THE HORIZONTAL.
    +
    87 !
    +
    88 !!$omp parallel do private(i,j,l,ie,iw,cs,ct,dthvkl,dukl,dvkl, &
    +
    89 !!$omp& rdzkl,ri,uhkl,ulkl,vhkl,vlkl,wndsl,wndslp)
    +
    90  DO l = 1,lm1
    +
    91 !
    +
    92  if(gridtype /= 'A')THEN
    +
    93  call exch(vtm(1,jsta_2l,l))
    +
    94  call exch(uh(1,jsta_2l,l))
    +
    95  call exch(vh(1,jsta_2l,l))
    +
    96  call exch(vtm(1,jsta_2l,l+1))
    +
    97  call exch(uh(1,jsta_2l,l+1))
    +
    98  call exch(vh(1,jsta_2l,l+1))
    +
    99  end if
    +
    100 
    +
    101  DO j=jsta_m,jend_m
    +
    102  DO i=ista_m,iend_m
    +
    103 !
    +
    104  IF(gridtype == 'A')THEN
    +
    105  uhkl = uh(i,j,l)
    +
    106  ulkl = uh(i,j,l+1)
    +
    107  vhkl = vh(i,j,l)
    +
    108  vlkl = vh(i,j,l+1)
    +
    109  ELSE IF(gridtype == 'E')THEN
    +
    110  ie = i+mod(j+1,2)
    +
    111  iw = i+mod(j+1,2)-1
    +
    112 !
    +
    113 ! WE NEED (U,V) WINDS AT A MASS POINT. FOUR POINT
    +
    114 ! AVERAGE (U,V) WINDS TO MASS POINT. NORMALIZE FOUR
    +
    115 ! POINT AVERAGE BY THE ACTUAL NUMBER OF (U,V) WINDS
    +
    116 ! USED IN THE AVERAGING. VTM=1 IF WIND POINT IS
    +
    117 ! ABOVE GROUND. VTM=0 IF BELOW GROUND.
    +
    118 !
    +
    119  wndsl = vtm(i,j-1,l)+vtm(iw,j,l)+vtm(ie,j,l)+vtm(i,j+1,l)
    +
    120  wndslp = vtm(i,j-1,l+1) + vtm(iw,j,l+1)+ &
    +
    121  vtm(ie,j,l+1) + vtm(i,j+1,l+1)
    +
    122  IF(wndsl == 0. .OR. wndslp == 0.) cycle
    +
    123  uhkl = (uh(i,j-1,l)+uh(iw,j,l)+uh(ie,j,l)+uh(i,j+1,l))/wndsl
    +
    124  ulkl = (uh(i,j-1,l+1)+uh(iw,j,l+1)+uh(ie,j,l+1)+ &
    +
    125  uh(i,j+1,l+1))/wndslp
    +
    126  vhkl = (vh(i,j-1,l)+vh(iw,j,l)+vh(ie,j,l)+vh(i,j+1,l))/wndsl
    +
    127  vlkl = (vh(i,j-1,l+1)+vh(iw,j,l+1)+vh(ie,j,l+1)+ &
    +
    128  vh(i,j+1,l+1))/wndslp
    +
    129  ELSE IF(gridtype == 'B')THEN
    +
    130  ie = i
    +
    131  iw = i-1
    +
    132  uhkl = (uh(iw,j-1,l)+uh(iw,j,l)+uh(ie,j-1,l)+uh(i,j,l))/4.0
    +
    133  ulkl = (uh(iw,j-1,l+1)+uh(iw,j,l+1)+uh(ie,j-1,l+1)+ &
    +
    134  uh(i,j,l+1))/4.0
    +
    135  vhkl = (vh(iw,j-1,l)+vh(iw,j,l)+vh(ie,j-1,l)+vh(i,j,l))/4.0
    +
    136  vlkl = (vh(iw,j-1,l+1)+vh(iw,j,l+1)+vh(ie,j-1,l+1)+ &
    +
    137  vh(i,j,l+1))/4.0
    +
    138  END IF
    +
    139 
    +
    140  rdzkl = 1.0 / (zmid(i,j,l)-zmid(i,j,l+1))
    +
    141 
    +
    142 ! Q2KL = MAX(Q2(I,J,L),0.00001)
    +
    143 ! QROOT = SQRT(Q2KL)
    +
    144 ! ELKL = EL(I,J,L)
    +
    145 ! ELKL = MAX(ELKL,EPSQ2)
    +
    146 ! ELKLSQ = ELKL*ELKL
    +
    147 
    +
    148  dthvkl = thv(i,j,l)-thv(i,j,l+1)
    +
    149  dukl = (uhkl-ulkl) * rdzkl
    +
    150  dvkl = (vhkl-vlkl) * rdzkl
    +
    151  cs = dukl*dukl + dvkl*dvkl
    +
    152 !
    +
    153 ! COMPUTE GRADIENT RICHARDSON NUMBER.
    +
    154 !
    +
    155  IF(cs <= 1.e-8) THEN
    156 !
    -
    157 ! WIND SHEAR LARGE ENOUGH TO USE RICHARDSON NUMBER.
    -
    158 !
    -
    159  ct = -1.*g*beta*dthvkl*rdzkl
    -
    160  ri = -ct/cs
    -
    161  richno(i,j,l) = ri
    -
    162  ENDIF
    +
    157 ! WIND SHEAR IS VANISHINGLY SMALL - SO SET RICHARDSON
    +
    158 ! NUMBER TO POST PROCESSOR SPECIAL VALUE.
    +
    159 !
    +
    160  richno(i,j,l) = spval
    +
    161 !
    +
    162  ELSE
    163 !
    -
    164  ENDDO
    -
    165  ENDDO
    -
    166  ENDDO ! end of l loop
    -
    167 !
    -
    168  DEALLOCATE (thv)
    -
    169 ! END OF ROUTINE.
    -
    170 !
    -
    171  RETURN
    -
    172  END
    -
    173 
    +
    164 ! WIND SHEAR LARGE ENOUGH TO USE RICHARDSON NUMBER.
    +
    165 !
    +
    166  ct = -1.*g*beta*dthvkl*rdzkl
    +
    167  ri = -ct/cs
    +
    168  richno(i,j,l) = ri
    +
    169  ENDIF
    +
    170 !
    +
    171  ENDDO
    +
    172  ENDDO
    +
    173  ENDDO ! end of l loop
    +
    174 !
    +
    175  DEALLOCATE (thv)
    +
    176 ! END OF ROUTINE.
    +
    177 !
    +
    178  RETURN
    +
    179  END
    +
    180 
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    masks
    Definition: MASKS_mod.f:1
    params_mod
    Definition: params.F:1
    - +
    calrch
    subroutine calrch(EL, RICHNO)
    Subroutine that computes GRD RCH number.
    Definition: CALRCH.f:31
    +
    @@ -268,7 +273,7 @@
  • sorc
  • ncep_post.fd
  • CALRCH.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALSTRM_8f.html b/CALSTRM_8f.html index 2e9b23a9e..8af14700a 100644 --- a/CALSTRM_8f.html +++ b/CALSTRM_8f.html @@ -3,7 +3,7 @@ - + UPP: CALSTRM.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALSTRM (Z1D, STRM)
     
    subroutine calstrm (Z1D, STRM)
     Subroutine that computes geo streamfunction. More...
     

    Detailed Description

    Subroutine that computes geo streamfunction.

    @@ -149,7 +149,47 @@

    Program history log:

    Date
    1992-12-22

    Definition in file CALSTRM.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine calstrm (real, dimension(ista:iend,jsta:jend), intent(in) Z1D,
    real, dimension(ista:iend,jsta:jend), intent(inout) STRM 
    )
    +
    + +

    Subroutine that computes geo streamfunction.

    +
    Parameters
    + + + +
    [in]Z1DGeopotential height (m).
    [out]STRMGeostrophic streamfunction.
    +
    +
    + +

    Definition at line 31 of file CALSTRM.f.

    + +

    Referenced by mdlfld().

    + +
    +
    + diff --git a/CALSTRM_8f.js b/CALSTRM_8f.js index c9027f9e5..f3b9718af 100644 --- a/CALSTRM_8f.js +++ b/CALSTRM_8f.js @@ -1,4 +1,4 @@ var CALSTRM_8f = [ - [ "CALSTRM", "CALSTRM_8f.html#a19639072df38ee5043536bfe47da23b2", null ] + [ "calstrm", "CALSTRM_8f.html#ae85fc932773bfd3191ef88fdb8c2ab78", null ] ]; \ No newline at end of file diff --git a/CALSTRM_8f_source.html b/CALSTRM_8f_source.html index 3c87ec62c..1f2ba54f9 100644 --- a/CALSTRM_8f_source.html +++ b/CALSTRM_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALSTRM.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,52 +107,56 @@
    Go to the documentation of this file.
    1 
    -
    25  SUBROUTINE calstrm(Z1D,STRM)
    -
    26 
    -
    27 !
    -
    28 !
    -
    29 !
    -
    30 !
    -
    31 ! INCLUDE ETA GRID DIMENSIONS. SET/DERIVE OTHER PARAMETERS.
    -
    32 !
    -
    33 ! use vrbls2d, only:
    -
    34  use params_mod, only: g
    -
    35  use ctlblk_mod, only: jsta, jend, im, ista, iend
    -
    36 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    37  implicit none
    -
    38 !
    -
    39  real,PARAMETER :: omega=7.292e-5,twomg=2*omega
    -
    40 !
    -
    41 ! DECLARE VARIABLES.
    -
    42 !
    -
    43 ! LOGICAL FIRST,OLDRD,RESTRT,RUN,SIGMA,STRD
    -
    44  REAL, dimension(ista:iend,jsta:jend), intent(in) :: z1d
    -
    45  REAL, dimension(ista:iend,jsta:jend), intent(inout) :: strm
    +
    25 !-----------------------------------------------------------------------
    +
    30 !-----------------------------------------------------------------------
    +
    31  SUBROUTINE calstrm(Z1D,STRM)
    +
    32 
    +
    33 !
    +
    34 !
    +
    35 !
    +
    36 !
    +
    37 ! INCLUDE ETA GRID DIMENSIONS. SET/DERIVE OTHER PARAMETERS.
    +
    38 !
    +
    39 ! use vrbls2d, only:
    +
    40  use params_mod, only: g
    +
    41  use ctlblk_mod, only: jsta, jend, im, ista, iend
    +
    42 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    43  implicit none
    +
    44 !
    +
    45  real,PARAMETER :: omega=7.292e-5,twomg=2*omega
    46 !
    -
    47  LOGICAL oldrd,strd
    -
    48  integer imid,i,j
    -
    49  real f0,gof0
    -
    50 !
    -
    51 !***************************************************************************
    -
    52 ! START CALSTRM HERE.
    -
    53 !
    -
    54 ! COMPUTE CORIOLIS PARAMETER AT 40N
    -
    55 !
    -
    56  imid=im/2
    -
    57  f0 = 1.454441e-4*sin(40.0*0.01745329)
    -
    58  gof0 = g/f0
    +
    47 ! DECLARE VARIABLES.
    +
    48 !
    +
    49 ! LOGICAL FIRST,OLDRD,RESTRT,RUN,SIGMA,STRD
    +
    50  REAL, dimension(ista:iend,jsta:jend), intent(in) :: z1d
    +
    51  REAL, dimension(ista:iend,jsta:jend), intent(inout) :: strm
    +
    52 !
    +
    53  LOGICAL oldrd,strd
    +
    54  integer imid,i,j
    +
    55  real f0,gof0
    +
    56 !
    +
    57 !***************************************************************************
    +
    58 ! START CALSTRM HERE.
    59 !
    -
    60 ! COMPUTE GEOSTROPHIC STREAMFUNCTION.
    -
    61 !$omp parallel do
    -
    62  DO j=jsta,jend
    -
    63  DO i=ista,iend
    -
    64  strm(i,j) = gof0*z1d(i,j)
    -
    65  ENDDO
    -
    66  ENDDO
    -
    67 !
    -
    68 ! END OF ROUTINE.
    -
    69  RETURN
    -
    70  END
    +
    60 ! COMPUTE CORIOLIS PARAMETER AT 40N
    +
    61 !
    +
    62  imid=im/2
    +
    63  f0 = 1.454441e-4*sin(40.0*0.01745329)
    +
    64  gof0 = g/f0
    +
    65 !
    +
    66 ! COMPUTE GEOSTROPHIC STREAMFUNCTION.
    +
    67 !$omp parallel do
    +
    68  DO j=jsta,jend
    +
    69  DO i=ista,iend
    +
    70  strm(i,j) = gof0*z1d(i,j)
    +
    71  ENDDO
    +
    72  ENDDO
    +
    73 !
    +
    74 ! END OF ROUTINE.
    +
    75  RETURN
    +
    76  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    +
    calstrm
    subroutine calstrm(Z1D, STRM)
    Subroutine that computes geo streamfunction.
    Definition: CALSTRM.f:31
    params_mod
    Definition: params.F:1
    @@ -162,7 +166,7 @@
  • sorc
  • ncep_post.fd
  • CALSTRM.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALTAU_8f.html b/CALTAU_8f.html index ba5a9c027..f41b31891 100644 --- a/CALTAU_8f.html +++ b/CALTAU_8f.html @@ -3,7 +3,7 @@ - + UPP: CALTAU.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALTAU (TAUX, TAUY)
     
    subroutine caltau (TAUX, TAUY)
     Subroutine that computes U and V wind stresses. More...
     

    Detailed Description

    Subroutine that computes U and V wind stresses.

    @@ -158,7 +158,47 @@

    Program history log:

    Date
    1993-09-01

    Definition in file CALTAU.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine caltau (real, dimension(ista:iend,jsta:jend), intent(inout) TAUX,
    real, dimension(ista:iend,jsta:jend), intent(inout) TAUY 
    )
    +
    + +

    Subroutine that computes U and V wind stresses.

    +
    Parameters
    + + + +
    [out]TAUXSuface layer U component wind stress.
    [out]TAUYSuface layer V component wind stress.
    +
    +
    + +

    Definition at line 33 of file CALTAU.f.

    + +

    Referenced by surfce().

    + +
    +
    + diff --git a/CALTAU_8f.js b/CALTAU_8f.js index b27b997be..6c5e6d99b 100644 --- a/CALTAU_8f.js +++ b/CALTAU_8f.js @@ -1,4 +1,4 @@ var CALTAU_8f = [ - [ "CALTAU", "CALTAU_8f.html#a7874614056661c5a3ba8825ca0b701e7", null ] + [ "caltau", "CALTAU_8f.html#a5b80a2ddec6a3749ea87078d3214b5c8", null ] ]; \ No newline at end of file diff --git a/CALTAU_8f_source.html b/CALTAU_8f_source.html index 9d0879904..c44c1c74a 100644 --- a/CALTAU_8f_source.html +++ b/CALTAU_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALTAU.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,221 +107,224 @@
    Go to the documentation of this file.
    1 
    -
    27 
    -
    28  SUBROUTINE caltau(TAUX,TAUY)
    -
    29 
    -
    30 !
    -
    31 !
    -
    32  use vrbls3d, only: zint, pmid, q, t, uh, vh, el_pbl, zmid
    -
    33  use vrbls2d, only: z0, uz0, vz0
    -
    34  use masks, only: lmh
    -
    35  use params_mod, only: d00, d50, h1, d608, rd, d25
    -
    36  use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, spval, jsta_m,&
    -
    37  jm, im, jend_m, ista, iend, ista_m, iend_m, ista_2l, iend_2u
    -
    38  use gridspec_mod, only: gridtype
    -
    39 
    -
    40  implicit none
    -
    41 !
    -
    42 ! DECLARE VARIABLES.
    -
    43  INTEGER, dimension(4) :: kk(4)
    -
    44  INTEGER, dimension(jm) :: ive, ivw
    -
    45  REAL, dimension(ista:iend,jsta:jend), intent(inout) :: taux, tauy
    -
    46  REAL, ALLOCATABLE :: el(:,:,:)
    -
    47  REAL, dimension(ista:iend,jsta:jend) :: egridu,egridv,egrid4,egrid5, el0
    -
    48  REAL uz0v,vz0v
    -
    49  CHARACTER*1 agrid
    -
    50  integer i,j,lmhk,ie,iw,ii,jj
    -
    51  real dz,rdz,rsfc,tv,rho,ulmh,vlmh,deludz,delvdz,elsqr,zint1, &
    -
    52  zint2,z0v,psfc,tvv,qvv,elv,elv1,elv2
    -
    53 !
    -
    54 !********************************************************************
    -
    55 ! START CALTAU HERE.
    -
    56 !
    -
    57  ALLOCATE (el(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
    -
    58 !
    -
    59 ! COMPUTE MASTER LENGTH SCALE.
    -
    60 !
    -
    61 ! CALL CLMAX(EL0,EGRIDU,EGRIDV,EGRID4,EGRID5)
    -
    62 ! CALL MIXLEN(EL0,EL)
    -
    63 !
    -
    64 ! INITIALIZE OUTPUT AND WORK ARRAY TO ZERO.
    -
    65 !
    -
    66  DO j=jsta,jend
    -
    67  DO i=ista,iend
    -
    68  egridu(i,j) = d00
    -
    69  egridv(i,j) = d00
    -
    70  taux(i,j) = spval
    -
    71  tauy(i,j) = spval
    -
    72  ENDDO
    -
    73  ENDDO
    -
    74 !
    -
    75 ! COMPUTE SURFACE LAYER U AND V WIND STRESSES.
    -
    76 !
    -
    77 ! ASSUME THAT U AND V HAVE UPDATED HALOS
    -
    78 !
    -
    79  IF(gridtype == 'A')THEN
    -
    80  CALL clmax(el0,egridu,egridv,egrid4,egrid5)
    -
    81  CALL mixlen(el0,el)
    -
    82 
    -
    83  DO j=jsta,jend
    -
    84  DO i=ista,iend
    -
    85 !
    -
    86  lmhk = nint(lmh(i,j))
    -
    87  IF(el(i,j,lmhk-1)<spval.and.z0(i,j)<spval.and. &
    -
    88  uz0(i,j)<spval.and.vz0(i,j)<spval)THEN
    -
    89 !
    -
    90 ! COMPUTE THICKNESS OF LAYER AT MASS POINT.
    -
    91 !
    -
    92  dz = d50*(zint(i,j,lmhk)-zint(i,j,lmhk+1))
    -
    93  dz = dz-z0(i,j)
    -
    94  rdz = 1./dz
    -
    95 !
    -
    96 ! COMPUTE REPRESENTATIVE AIR DENSITY.
    -
    97 !
    -
    98  psfc = pmid(i,j,lmhk)
    -
    99  tv = (h1+d608*q(i,j,lmhk))*t(i,j,lmhk)
    -
    100  rho = psfc/(rd*tv)
    -
    101 !
    -
    102 ! COMPUTE A MEAN MASS POINT WIND IN THE
    -
    103 ! FIRST ATMOSPHERIC ETA LAYER.
    -
    104 !
    -
    105  ulmh = uh(i,j,lmhk)
    -
    106  vlmh = vh(i,j,lmhk)
    -
    107 !
    -
    108 ! COMPUTE WIND SHEAR COMPONENTS ACROSS LAYER.
    +
    27 !-----------------------------------------------------------------------
    +
    32 !-----------------------------------------------------------------------
    +
    33  SUBROUTINE caltau(TAUX,TAUY)
    +
    34 
    +
    35 !
    +
    36 !
    +
    37  use vrbls3d, only: zint, pmid, q, t, uh, vh, el_pbl, zmid
    +
    38  use vrbls2d, only: z0, uz0, vz0
    +
    39  use masks, only: lmh
    +
    40  use params_mod, only: d00, d50, h1, d608, rd, d25
    +
    41  use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, spval, jsta_m,&
    +
    42  jm, im, jend_m, ista, iend, ista_m, iend_m, ista_2l, iend_2u
    +
    43  use gridspec_mod, only: gridtype
    +
    44 
    +
    45  implicit none
    +
    46 !
    +
    47 ! DECLARE VARIABLES.
    +
    48  INTEGER, dimension(4) :: kk(4)
    +
    49  INTEGER, dimension(jm) :: ive, ivw
    +
    50  REAL, dimension(ista:iend,jsta:jend), intent(inout) :: taux, tauy
    +
    51  REAL, ALLOCATABLE :: el(:,:,:)
    +
    52  REAL, dimension(ista:iend,jsta:jend) :: egridu,egridv,egrid4,egrid5, el0
    +
    53  REAL uz0v,vz0v
    +
    54  CHARACTER*1 agrid
    +
    55  integer i,j,lmhk,ie,iw,ii,jj
    +
    56  real dz,rdz,rsfc,tv,rho,ulmh,vlmh,deludz,delvdz,elsqr,zint1, &
    +
    57  zint2,z0v,psfc,tvv,qvv,elv,elv1,elv2
    +
    58 !
    +
    59 !********************************************************************
    +
    60 ! START CALTAU HERE.
    +
    61 !
    +
    62  ALLOCATE (el(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
    +
    63 !
    +
    64 ! COMPUTE MASTER LENGTH SCALE.
    +
    65 !
    +
    66 ! CALL CLMAX(EL0,EGRIDU,EGRIDV,EGRID4,EGRID5)
    +
    67 ! CALL MIXLEN(EL0,EL)
    +
    68 !
    +
    69 ! INITIALIZE OUTPUT AND WORK ARRAY TO ZERO.
    +
    70 !
    +
    71  DO j=jsta,jend
    +
    72  DO i=ista,iend
    +
    73  egridu(i,j) = d00
    +
    74  egridv(i,j) = d00
    +
    75  taux(i,j) = spval
    +
    76  tauy(i,j) = spval
    +
    77  ENDDO
    +
    78  ENDDO
    +
    79 !
    +
    80 ! COMPUTE SURFACE LAYER U AND V WIND STRESSES.
    +
    81 !
    +
    82 ! ASSUME THAT U AND V HAVE UPDATED HALOS
    +
    83 !
    +
    84  IF(gridtype == 'A')THEN
    +
    85  CALL clmax(el0,egridu,egridv,egrid4,egrid5)
    +
    86  CALL mixlen(el0,el)
    +
    87 
    +
    88  DO j=jsta,jend
    +
    89  DO i=ista,iend
    +
    90 !
    +
    91  lmhk = nint(lmh(i,j))
    +
    92  IF(el(i,j,lmhk-1)<spval.and.z0(i,j)<spval.and. &
    +
    93  uz0(i,j)<spval.and.vz0(i,j)<spval)THEN
    +
    94 !
    +
    95 ! COMPUTE THICKNESS OF LAYER AT MASS POINT.
    +
    96 !
    +
    97  dz = d50*(zint(i,j,lmhk)-zint(i,j,lmhk+1))
    +
    98  dz = dz-z0(i,j)
    +
    99  rdz = 1./dz
    +
    100 !
    +
    101 ! COMPUTE REPRESENTATIVE AIR DENSITY.
    +
    102 !
    +
    103  psfc = pmid(i,j,lmhk)
    +
    104  tv = (h1+d608*q(i,j,lmhk))*t(i,j,lmhk)
    +
    105  rho = psfc/(rd*tv)
    +
    106 !
    +
    107 ! COMPUTE A MEAN MASS POINT WIND IN THE
    +
    108 ! FIRST ATMOSPHERIC ETA LAYER.
    109 !
    -
    110  deludz = (ulmh-uz0(i,j))*rdz
    -
    111  delvdz = (vlmh-vz0(i,j))*rdz
    -
    112 !
    -
    113 ! COMPUTE U (EGRIDU) AND V (EGRIDV) WIND STRESSES.
    +
    110  ulmh = uh(i,j,lmhk)
    +
    111  vlmh = vh(i,j,lmhk)
    +
    112 !
    +
    113 ! COMPUTE WIND SHEAR COMPONENTS ACROSS LAYER.
    114 !
    -
    115  elsqr = el(i,j,lmhk-1)*el(i,j,lmhk-1)
    -
    116  taux(i,j) = rho*elsqr*deludz*deludz
    -
    117  tauy(i,j) = rho*elsqr*delvdz*delvdz
    -
    118  ELSE
    -
    119  taux(i,j) = spval
    -
    120  tauy(i,j) = spval
    -
    121  ENDIF
    -
    122 
    -
    123 !
    -
    124  END DO
    -
    125  END DO
    -
    126  ELSE IF(gridtype == 'E')THEN
    -
    127  call exch(zint(1,jsta_2l,lm))
    -
    128  call exch(zint(1,jsta_2l,lm+1))
    -
    129  call exch(z0(1,jsta_2l))
    -
    130  call exch(pmid(1,jsta_2l,lm))
    -
    131  call exch(t(1,jsta_2l,lm))
    -
    132  call exch(q(1,jsta_2l,lm))
    -
    133  call exch(el_pbl(1,jsta_2l,lm))
    -
    134  call exch(el_pbl(1,jsta_2l,lm-1))
    -
    135 
    -
    136  DO j=jsta_m,jend_m
    -
    137  ive(j)=mod(j,2)
    -
    138  ivw(j)=ive(j)-1
    -
    139  ENDDO
    -
    140 
    +
    115  deludz = (ulmh-uz0(i,j))*rdz
    +
    116  delvdz = (vlmh-vz0(i,j))*rdz
    +
    117 !
    +
    118 ! COMPUTE U (EGRIDU) AND V (EGRIDV) WIND STRESSES.
    +
    119 !
    +
    120  elsqr = el(i,j,lmhk-1)*el(i,j,lmhk-1)
    +
    121  taux(i,j) = rho*elsqr*deludz*deludz
    +
    122  tauy(i,j) = rho*elsqr*delvdz*delvdz
    +
    123  ELSE
    +
    124  taux(i,j) = spval
    +
    125  tauy(i,j) = spval
    +
    126  ENDIF
    +
    127 
    +
    128 !
    +
    129  END DO
    +
    130  END DO
    +
    131  ELSE IF(gridtype == 'E')THEN
    +
    132  call exch(zint(1,jsta_2l,lm))
    +
    133  call exch(zint(1,jsta_2l,lm+1))
    +
    134  call exch(z0(1,jsta_2l))
    +
    135  call exch(pmid(1,jsta_2l,lm))
    +
    136  call exch(t(1,jsta_2l,lm))
    +
    137  call exch(q(1,jsta_2l,lm))
    +
    138  call exch(el_pbl(1,jsta_2l,lm))
    +
    139  call exch(el_pbl(1,jsta_2l,lm-1))
    +
    140 
    141  DO j=jsta_m,jend_m
    -
    142  DO i=ista_m,iend_m
    -
    143 !
    -
    144  lmhk = nint(lmh(i,j))
    -
    145  ie=i+ive(j)
    -
    146  iw=i+ivw(j)
    -
    147  zint1=(zint(iw,j,lmhk)+zint(ie,j,lmhk) &
    -
    148  +zint(i,j+1,lmhk)+zint(i,j-1,lmhk))*d25
    -
    149  zint2=(zint(iw,j,lmhk+1)+zint(ie,j,lmhk+1) &
    -
    150  +zint(i,j+1,lmhk+1)+zint(i,j-1,lmhk+1))*d25
    -
    151  dz = d50*(zint1-zint2)
    -
    152  z0v=(z0(iw,j)+z0(ie,j)+z0(i,j+1)+z0(i,j-1))*d25
    -
    153  dz = dz-z0v
    -
    154  rdz = 1./dz
    -
    155 !
    -
    156 ! COMPUTE REPRESENTATIVE AIR DENSITY.
    -
    157 !
    -
    158  psfc = (pmid(iw,j,lmhk)+pmid(ie,j,lmhk) &
    -
    159  +pmid(i,j+1,lmhk)+pmid(i,j-1,lmhk))*d25
    -
    160  tvv = (t(iw,j,lmhk)+t(ie,j,lmhk) &
    -
    161  +t(i,j+1,lmhk)+t(i,j-1,lmhk))*d25
    -
    162  qvv = (q(iw,j,lmhk)+q(ie,j,lmhk) &
    -
    163  +q(i,j+1,lmhk)+q(i,j-1,lmhk))*d25
    -
    164  tv = (h1+d608*qvv)*tvv
    -
    165  rho = psfc/(rd*tv)
    -
    166 
    -
    167 ! COMPUTE WIND SHEAR COMPONENTS ACROSS LAYER.
    -
    168 !
    -
    169  deludz = (uh(i,j,lmhk)-uz0(i,j))*rdz
    -
    170  delvdz = (vh(i,j,lmhk)-vz0(i,j))*rdz
    +
    142  ive(j)=mod(j,2)
    +
    143  ivw(j)=ive(j)-1
    +
    144  ENDDO
    +
    145 
    +
    146  DO j=jsta_m,jend_m
    +
    147  DO i=ista_m,iend_m
    +
    148 !
    +
    149  lmhk = nint(lmh(i,j))
    +
    150  ie=i+ive(j)
    +
    151  iw=i+ivw(j)
    +
    152  zint1=(zint(iw,j,lmhk)+zint(ie,j,lmhk) &
    +
    153  +zint(i,j+1,lmhk)+zint(i,j-1,lmhk))*d25
    +
    154  zint2=(zint(iw,j,lmhk+1)+zint(ie,j,lmhk+1) &
    +
    155  +zint(i,j+1,lmhk+1)+zint(i,j-1,lmhk+1))*d25
    +
    156  dz = d50*(zint1-zint2)
    +
    157  z0v=(z0(iw,j)+z0(ie,j)+z0(i,j+1)+z0(i,j-1))*d25
    +
    158  dz = dz-z0v
    +
    159  rdz = 1./dz
    +
    160 !
    +
    161 ! COMPUTE REPRESENTATIVE AIR DENSITY.
    +
    162 !
    +
    163  psfc = (pmid(iw,j,lmhk)+pmid(ie,j,lmhk) &
    +
    164  +pmid(i,j+1,lmhk)+pmid(i,j-1,lmhk))*d25
    +
    165  tvv = (t(iw,j,lmhk)+t(ie,j,lmhk) &
    +
    166  +t(i,j+1,lmhk)+t(i,j-1,lmhk))*d25
    +
    167  qvv = (q(iw,j,lmhk)+q(ie,j,lmhk) &
    +
    168  +q(i,j+1,lmhk)+q(i,j-1,lmhk))*d25
    +
    169  tv = (h1+d608*qvv)*tvv
    +
    170  rho = psfc/(rd*tv)
    171 
    -
    172 ! COMPUTE U (EGRIDU) AND V (EGRIDV) WIND STRESSES.
    -
    173 !
    -
    174  elv1=(el_pbl(iw,j,lmhk)+el_pbl(ie,j,lmhk) &
    -
    175  +el_pbl(i,j+1,lmhk)+el_pbl(i,j-1,lmhk))*d25
    -
    176  elv2=(el_pbl(iw,j,lmhk-1)+el_pbl(ie,j,lmhk-1) &
    -
    177  +el_pbl(i,j+1,lmhk-1)+el_pbl(i,j-1,lmhk-1))*d25
    -
    178  elv=(elv1+elv2)/2.0 ! EL is defined at the bottom of layer
    -
    179  elsqr =elv*elv
    -
    180  taux(i,j)=rho*elsqr*deludz*deludz
    -
    181  tauy(i,j)=rho*elsqr*delvdz*delvdz
    -
    182 ! ii=im/2
    -
    183 ! jj=(jsta+jend)/2
    -
    184 ! if(i==ii.and.j==jj)print*,'sample tau'
    -
    185 ! & ,RHO,ELSQR,DELUDZ,DELVDZ
    -
    186  END DO
    -
    187  END DO
    -
    188  ELSE IF(gridtype == 'B')THEN
    -
    189 ! PUT TAUX AND TAUY ON MASS POINTS
    -
    190  call exch(vh(1,jsta_2l,lm))
    -
    191  DO j=jsta_m,jend_m
    -
    192  DO i=ista_m,iend_m
    -
    193 !
    -
    194  lmhk = nint(lmh(i,j))
    -
    195 !
    -
    196 ! COMPUTE THICKNESS OF LAYER AT MASS POINT.
    -
    197 !
    -
    198 ! DZ = D50*(ZINT(I,J,LMHK)-ZINT(I,J,LMHK+1))
    -
    199 ! DZ = ZMID(I,J,LMHK)-Z0(I,J)
    -
    200  dz=zmid(i,j,lmhk)-(z0(i,j)+zint(i,j,lmhk+1))
    -
    201  if(dz==0.0)dz=0.2
    -
    202  rdz = 1./dz
    -
    203 !
    -
    204 ! COMPUTE REPRESENTATIVE AIR DENSITY.
    -
    205 !
    -
    206  psfc = pmid(i,j,lmhk)
    -
    207  tv = (h1+d608*q(i,j,lmhk))*t(i,j,lmhk)
    -
    208  rho = psfc/(rd*tv)
    -
    209 !
    -
    210 ! PUT U AND V ONTO MASS POINTS
    -
    211 !
    -
    212  ulmh = 0.5*(uh(i-1,j,lmhk)+uh(i,j,lmhk))
    -
    213  vlmh = 0.5*(vh(i,j-1,lmhk)+vh(i,j,lmhk))
    -
    214 !
    -
    215 ! COMPUTE WIND SHEAR COMPONENTS ACROSS LAYER.
    +
    172 ! COMPUTE WIND SHEAR COMPONENTS ACROSS LAYER.
    +
    173 !
    +
    174  deludz = (uh(i,j,lmhk)-uz0(i,j))*rdz
    +
    175  delvdz = (vh(i,j,lmhk)-vz0(i,j))*rdz
    +
    176 
    +
    177 ! COMPUTE U (EGRIDU) AND V (EGRIDV) WIND STRESSES.
    +
    178 !
    +
    179  elv1=(el_pbl(iw,j,lmhk)+el_pbl(ie,j,lmhk) &
    +
    180  +el_pbl(i,j+1,lmhk)+el_pbl(i,j-1,lmhk))*d25
    +
    181  elv2=(el_pbl(iw,j,lmhk-1)+el_pbl(ie,j,lmhk-1) &
    +
    182  +el_pbl(i,j+1,lmhk-1)+el_pbl(i,j-1,lmhk-1))*d25
    +
    183  elv=(elv1+elv2)/2.0 ! EL is defined at the bottom of layer
    +
    184  elsqr =elv*elv
    +
    185  taux(i,j)=rho*elsqr*deludz*deludz
    +
    186  tauy(i,j)=rho*elsqr*delvdz*delvdz
    +
    187 ! ii=im/2
    +
    188 ! jj=(jsta+jend)/2
    +
    189 ! if(i==ii.and.j==jj)print*,'sample tau'
    +
    190 ! & ,RHO,ELSQR,DELUDZ,DELVDZ
    +
    191  END DO
    +
    192  END DO
    +
    193  ELSE IF(gridtype == 'B')THEN
    +
    194 ! PUT TAUX AND TAUY ON MASS POINTS
    +
    195  call exch(vh(1,jsta_2l,lm))
    +
    196  DO j=jsta_m,jend_m
    +
    197  DO i=ista_m,iend_m
    +
    198 !
    +
    199  lmhk = nint(lmh(i,j))
    +
    200 !
    +
    201 ! COMPUTE THICKNESS OF LAYER AT MASS POINT.
    +
    202 !
    +
    203 ! DZ = D50*(ZINT(I,J,LMHK)-ZINT(I,J,LMHK+1))
    +
    204 ! DZ = ZMID(I,J,LMHK)-Z0(I,J)
    +
    205  dz=zmid(i,j,lmhk)-(z0(i,j)+zint(i,j,lmhk+1))
    +
    206  if(dz==0.0)dz=0.2
    +
    207  rdz = 1./dz
    +
    208 !
    +
    209 ! COMPUTE REPRESENTATIVE AIR DENSITY.
    +
    210 !
    +
    211  psfc = pmid(i,j,lmhk)
    +
    212  tv = (h1+d608*q(i,j,lmhk))*t(i,j,lmhk)
    +
    213  rho = psfc/(rd*tv)
    +
    214 !
    +
    215 ! PUT U AND V ONTO MASS POINTS
    216 !
    -
    217  deludz = (ulmh-uz0(i,j))*rdz
    -
    218  delvdz = (vlmh-vz0(i,j))*rdz
    -
    219 !
    -
    220 ! COMPUTE U (EGRIDU) AND V (EGRIDV) WIND STRESSES.
    +
    217  ulmh = 0.5*(uh(i-1,j,lmhk)+uh(i,j,lmhk))
    +
    218  vlmh = 0.5*(vh(i,j-1,lmhk)+vh(i,j,lmhk))
    +
    219 !
    +
    220 ! COMPUTE WIND SHEAR COMPONENTS ACROSS LAYER.
    221 !
    -
    222  elv=0.5*(el_pbl(i,j,lmhk)+el_pbl(i,j,lmhk-1))
    -
    223  elsqr = elv*elv
    -
    224  taux(i,j) = rho*elsqr*deludz*deludz
    -
    225 ! if(TAUX(I,J)>1.0e2)print*,'Debug TAUX= ',i,j, &
    -
    226 ! ELV,ULMH,UZ0(I,J),ZMID(I,J,LMHK),Z0(I,J),RDZ,TAUX(I,J),zint(i,j,lm+1)
    -
    227  tauy(i,j) = rho*elsqr*delvdz*delvdz
    -
    228 
    -
    229  END DO
    -
    230  END DO
    -
    231  END IF
    -
    232 !
    -
    233  DEALLOCATE(el)
    -
    234 ! END OF ROUTINE.
    -
    235 !
    -
    236  RETURN
    -
    237  END
    +
    222  deludz = (ulmh-uz0(i,j))*rdz
    +
    223  delvdz = (vlmh-vz0(i,j))*rdz
    +
    224 !
    +
    225 ! COMPUTE U (EGRIDU) AND V (EGRIDV) WIND STRESSES.
    +
    226 !
    +
    227  elv=0.5*(el_pbl(i,j,lmhk)+el_pbl(i,j,lmhk-1))
    +
    228  elsqr = elv*elv
    +
    229  taux(i,j) = rho*elsqr*deludz*deludz
    +
    230 ! if(TAUX(I,J)>1.0e2)print*,'Debug TAUX= ',i,j, &
    +
    231 ! ELV,ULMH,UZ0(I,J),ZMID(I,J,LMHK),Z0(I,J),RDZ,TAUX(I,J),zint(i,j,lm+1)
    +
    232  tauy(i,j) = rho*elsqr*delvdz*delvdz
    +
    233 
    +
    234  END DO
    +
    235  END DO
    +
    236  END IF
    +
    237 !
    +
    238  DEALLOCATE(el)
    +
    239 ! END OF ROUTINE.
    +
    240 !
    +
    241  RETURN
    +
    242  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    masks
    Definition: MASKS_mod.f:1
    params_mod
    Definition: params.F:1
    - + +
    caltau
    subroutine caltau(TAUX, TAUY)
    Subroutine that computes U and V wind stresses.
    Definition: CALTAU.f:33
    @@ -330,7 +333,7 @@
  • sorc
  • ncep_post.fd
  • CALTAU.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALTHTE_8f.html b/CALTHTE_8f.html index ac7cdbc58..c44b49937 100644 --- a/CALTHTE_8f.html +++ b/CALTHTE_8f.html @@ -3,7 +3,7 @@ - + UPP: CALTHTE.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALTHTE (P1D, T1D, Q1D, THTE)
     
    subroutine calthte (P1D, T1D, Q1D, THTE)
     Subroutine that computes Theta-E. More...
     

    Detailed Description

    Subroutine that computes Theta-E.

    @@ -151,7 +151,61 @@

    Program history log:

    Date
    1993-06-18

    Definition in file CALTHTE.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine calthte (real, dimension(ista:iend,jsta:jend), intent(in) P1D,
    real, dimension(ista:iend,jsta:jend), intent(in) T1D,
    real, dimension(ista:iend,jsta:jend), intent(in) Q1D,
    real, dimension(ista:iend,jsta:jend), intent(inout) THTE 
    )
    +
    + +

    Subroutine that computes Theta-E.

    +
    Parameters
    + + + + + +
    [in]P1Dpressure (Pa).
    [in]T1Dtemperature (K).
    [in]Q1Dspecific humidity(kg/kg).
    [out]THTETheta-E (K).
    +
    +
    + +

    Definition at line 31 of file CALTHTE.f.

    + +

    Referenced by miscln().

    + +
    +
    + diff --git a/CALTHTE_8f.js b/CALTHTE_8f.js index db1fc77c2..f5f5ac885 100644 --- a/CALTHTE_8f.js +++ b/CALTHTE_8f.js @@ -1,4 +1,4 @@ var CALTHTE_8f = [ - [ "CALTHTE", "CALTHTE_8f.html#a6a3ad1c0630ee3db731a38040c591872", null ] + [ "calthte", "CALTHTE_8f.html#ad5a42ea4380e28a231e6dda048e2b303", null ] ]; \ No newline at end of file diff --git a/CALTHTE_8f_source.html b/CALTHTE_8f_source.html index 835561abb..816db972e 100644 --- a/CALTHTE_8f_source.html +++ b/CALTHTE_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALTHTE.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,74 +107,77 @@
    Go to the documentation of this file.
    1 
    -
    23 
    -
    24  SUBROUTINE calthte(P1D,T1D,Q1D,THTE)
    -
    25 
    -
    26 !
    -
    27 !
    -
    28  use params_mod, only: d00, eps, oneps, d01, h1m12, p1000, h1
    -
    29  use ctlblk_mod, only: jsta, jend, im, spval, ista, iend
    -
    30 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    31  implicit none
    -
    32 !
    -
    33  real,PARAMETER :: kg2g=1.e3
    -
    34  real,PARAMETER :: d35=3.5,d4805=4.805,h2840=2840.,h55=55.
    -
    35  real,PARAMETER :: d2845=0.2845,d00028=0.00028,d3376=3.376
    -
    36  real,PARAMETER :: d00254=0.00254,d00081=0.00081,d81=0.81
    -
    37  real,PARAMETER :: d28=0.28,h2675=2675.
    -
    38 !
    -
    39 ! DECLARE VARIABLES.
    -
    40 !
    -
    41  REAL,dimension(ista:iend,jsta:jend),intent(in) :: p1d,t1d,q1d
    -
    42  REAL,dimension(ista:iend,jsta:jend),intent(inout) :: thte
    -
    43 
    -
    44  integer i,j
    -
    45  real p,t,q,evp,rmx,ckapa,rkapa,arg,denom,tlcl,plcl,fac, &
    -
    46  eterm,thetae
    +
    23 !--------------------------------------------------------------------------------------
    +
    30 !--------------------------------------------------------------------------------------
    +
    31  SUBROUTINE calthte(P1D,T1D,Q1D,THTE)
    +
    32 
    +
    33 !
    +
    34 !
    +
    35  use params_mod, only: d00, eps, oneps, d01, h1m12, p1000, h1
    +
    36  use ctlblk_mod, only: jsta, jend, im, spval, ista, iend
    +
    37 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    38  implicit none
    +
    39 !
    +
    40  real,PARAMETER :: kg2g=1.e3
    +
    41  real,PARAMETER :: d35=3.5,d4805=4.805,h2840=2840.,h55=55.
    +
    42  real,PARAMETER :: d2845=0.2845,d00028=0.00028,d3376=3.376
    +
    43  real,PARAMETER :: d00254=0.00254,d00081=0.00081,d81=0.81
    +
    44  real,PARAMETER :: d28=0.28,h2675=2675.
    +
    45 !
    +
    46 ! DECLARE VARIABLES.
    47 !
    -
    48 !***************************************************************
    -
    49 ! START CALTHTE.
    -
    50 !
    -
    51 ! ZERO THETA-E ARRAY
    -
    52 !$omp parallel do private(i,j)
    -
    53  DO j=jsta,jend
    -
    54  DO i=ista,iend
    -
    55  thte(i,j) = d00
    -
    56  ENDDO
    -
    57  ENDDO
    -
    58 !
    -
    59 ! COMPUTE THETA-E.
    -
    60 !
    -
    61 ! DO J=JSTA_M,JEND_M
    -
    62 ! DO I=ISTA_M,IEND_M
    -
    63 !$omp parallel do private(i,j,p,t,q,evp,rmx,ckapa,rkapa,arg,denom,tlcl,plcl,fac,eterm,thetae)
    -
    64  DO j=jsta,jend
    -
    65  DO i=ista,iend
    -
    66  IF(p1d(i,j)<spval.and.t1d(i,j)<spval.and.q1d(i,j)<spval)THEN
    -
    67  p = p1d(i,j)
    -
    68  t = t1d(i,j)
    -
    69  q = q1d(i,j)
    -
    70  evp = p*q/(eps+oneps*q)
    -
    71  rmx = eps*evp/(p-evp)
    -
    72  ckapa = d2845*(1.-d28*rmx)
    -
    73  rkapa = 1./ckapa
    -
    74  arg = max(h1m12, evp*d01)
    -
    75  denom = d35*log(t) - log(evp*d01) - d4805
    -
    76  tlcl = h2840/denom + h55
    -
    77  plcl = p*(tlcl/t)**rkapa
    -
    78  fac = (p1000/p)**ckapa
    -
    79  eterm = (d3376/tlcl-d00254)*(rmx*kg2g*(h1+d81*rmx))
    -
    80  thetae = t*fac*exp(eterm)
    -
    81  thte(i,j)= thetae
    -
    82  ENDIF
    -
    83  ENDDO
    -
    84  ENDDO
    -
    85 !
    -
    86 ! END OF ROUTINE.
    -
    87 !
    -
    88  RETURN
    -
    89  END
    +
    48  REAL,dimension(ista:iend,jsta:jend),intent(in) :: p1d,t1d,q1d
    +
    49  REAL,dimension(ista:iend,jsta:jend),intent(inout) :: thte
    +
    50 
    +
    51  integer i,j
    +
    52  real p,t,q,evp,rmx,ckapa,rkapa,arg,denom,tlcl,plcl,fac, &
    +
    53  eterm,thetae
    +
    54 !
    +
    55 !***************************************************************
    +
    56 ! START CALTHTE.
    +
    57 !
    +
    58 ! ZERO THETA-E ARRAY
    +
    59 !$omp parallel do private(i,j)
    +
    60  DO j=jsta,jend
    +
    61  DO i=ista,iend
    +
    62  thte(i,j) = d00
    +
    63  ENDDO
    +
    64  ENDDO
    +
    65 !
    +
    66 ! COMPUTE THETA-E.
    +
    67 !
    +
    68 ! DO J=JSTA_M,JEND_M
    +
    69 ! DO I=ISTA_M,IEND_M
    +
    70 !$omp parallel do private(i,j,p,t,q,evp,rmx,ckapa,rkapa,arg,denom,tlcl,plcl,fac,eterm,thetae)
    +
    71  DO j=jsta,jend
    +
    72  DO i=ista,iend
    +
    73  IF(p1d(i,j)<spval.and.t1d(i,j)<spval.and.q1d(i,j)<spval)THEN
    +
    74  p = p1d(i,j)
    +
    75  t = t1d(i,j)
    +
    76  q = q1d(i,j)
    +
    77  evp = p*q/(eps+oneps*q)
    +
    78  rmx = eps*evp/(p-evp)
    +
    79  ckapa = d2845*(1.-d28*rmx)
    +
    80  rkapa = 1./ckapa
    +
    81  arg = max(h1m12, evp*d01)
    +
    82  denom = d35*log(t) - log(evp*d01) - d4805
    +
    83  tlcl = h2840/denom + h55
    +
    84  plcl = p*(tlcl/t)**rkapa
    +
    85  fac = (p1000/p)**ckapa
    +
    86  eterm = (d3376/tlcl-d00254)*(rmx*kg2g*(h1+d81*rmx))
    +
    87  thetae = t*fac*exp(eterm)
    +
    88  thte(i,j)= thetae
    +
    89  ENDIF
    +
    90  ENDDO
    +
    91  ENDDO
    +
    92 !
    +
    93 ! END OF ROUTINE.
    +
    94 !
    +
    95  RETURN
    +
    96  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    params_mod
    Definition: params.F:1
    +
    calthte
    subroutine calthte(P1D, T1D, Q1D, THTE)
    Subroutine that computes Theta-E.
    Definition: CALTHTE.f:31
    @@ -183,7 +186,7 @@
  • sorc
  • ncep_post.fd
  • CALTHTE.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALUPDHEL_8f.html b/CALUPDHEL_8f.html index f0c44687b..81ac1c1c9 100644 --- a/CALUPDHEL_8f.html +++ b/CALUPDHEL_8f.html @@ -3,7 +3,7 @@ - + UPP: CALUPDHEL.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -116,9 +116,9 @@ - - + + +

    Functions/Subroutines

    -subroutine CALUPDHEL (UPDHEL)
     
    subroutine calupdhel (UPDHEL)
     Subroutine that computes the updraft helicity. More...
     

    Detailed Description

    Subroutine that computes the updraft helicity.

    @@ -144,12 +144,45 @@

    Program history log:

    2020-11-06 J Meng Use UPP_MATH Module 2021-10-31 J Meng 2D DECOMPOSITION + +2022-05-12 E James Adding a check for extremely large positive or negative UH values
    Author
    M Pyle W/NP2
    Date
    2007-10-22

    Definition in file CALUPDHEL.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + +
    subroutine calupdhel (real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) UPDHEL)
    +
    + +

    Subroutine that computes the updraft helicity.

    +
    Parameters
    + + +
    [out]UPDHELUpdraft helicity (m^2/s^2).
    +
    +
    + +

    Definition at line 23 of file CALUPDHEL.f.

    + +

    References upp_math::dvdxdudy().

    + +

    Referenced by miscln().

    + +
    +
    + diff --git a/CALUPDHEL_8f.js b/CALUPDHEL_8f.js index 9e8887c3b..6a82384df 100644 --- a/CALUPDHEL_8f.js +++ b/CALUPDHEL_8f.js @@ -1,4 +1,4 @@ var CALUPDHEL_8f = [ - [ "CALUPDHEL", "CALUPDHEL_8f.html#aae889bd9804c7539f0b2186a48d751f5", null ] + [ "calupdhel", "CALUPDHEL_8f.html#a96a88b0418b68c0f50a8d4542d3aabac", null ] ]; \ No newline at end of file diff --git a/CALUPDHEL_8f_source.html b/CALUPDHEL_8f_source.html index b3196ec8a..1c4386e5f 100644 --- a/CALUPDHEL_8f_source.html +++ b/CALUPDHEL_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALUPDHEL.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,128 +107,137 @@
    Go to the documentation of this file.
    1 
    -
    17  SUBROUTINE calupdhel(UPDHEL)
    -
    18 
    -
    19 !
    -
    20 !
    -
    21 ! use vrbls2d, only:
    -
    22  use vrbls3d, only: wh, uh, vh, zint, zmid
    -
    23  use masks, only: lmh, dx, dy
    -
    24  use params_mod, only: d00
    -
    25  use ctlblk_mod, only: lm, jsta_2l, jend_2u, jsta_m, jend_m, &
    -
    26  global, spval, im, jm, &
    -
    27  ista_2l, iend_2u, ista_m, iend_m
    -
    28  use gridspec_mod, only: gridtype
    -
    29  use upp_math, only: dvdxdudy, ddvdx, ddudy
    -
    30 
    -
    31  implicit none
    -
    32 
    -
    33 ! DECLARE VARIABLES.
    -
    34 !
    -
    35 ! LOGICAL RUN,FIRST,RESTRT,SIGMA,OLDRD,STRD
    -
    36  REAL, PARAMETER:: hlower=2000., hupper=5000.
    -
    37  REAL zmidloc
    -
    38  real :: r2dx, r2dy, dz, dcdx, dudy, dvdx
    -
    39  REAL :: htsfc(ista_2l:iend_2u,jsta_2l:jend_2u),updhel(ista_2l:iend_2u,jsta_2l:jend_2u)
    -
    40  integer :: l, j, i
    -
    41  INTEGER, dimension(jm) :: ihe,ihw
    -
    42 ! INTEGER DXVAL,DYVAL,CENLAT,CENLON,TRUELAT1,TRUELAT2
    -
    43 ! INTEGER LATSTART,LONSTART,LATLAST,LONLAST
    -
    44 !
    -
    45 !***************************************************************************
    -
    46 ! START CALUPDHEL HERE.
    -
    47 !
    -
    48 ! write(6,*) 'min/max WH(:,:,20):: ', minval(WH(:,:,20)), &
    -
    49 ! maxval(WH(:,:,20))
    -
    50 
    -
    51  DO l=1,lm
    -
    52  CALL exch(uh(ista_2l,jsta_2l,l))
    -
    53  END DO
    -
    54  IF (gridtype == 'B')THEN
    -
    55  DO l=1,lm
    -
    56  CALL exch(vh(ista_2l,jsta_2l,l))
    -
    57  END DO
    -
    58  END IF
    -
    59 !$omp parallel do private(i,j)
    -
    60  DO j=jsta_2l,jend_2u
    -
    61  DO i=ista_2l,iend_2u
    -
    62  updhel(i,j) = d00
    -
    63  ENDDO
    -
    64  ENDDO
    -
    65 
    +
    18 !--------------------------------------------------------------------------------------
    +
    22 !--------------------------------------------------------------------------------------
    +
    23  SUBROUTINE calupdhel(UPDHEL)
    +
    24 
    +
    25 !
    +
    26 !
    +
    27 ! use vrbls2d, only:
    +
    28  use vrbls3d, only: wh, uh, vh, zint, zmid
    +
    29  use masks, only: lmh, dx, dy
    +
    30  use params_mod, only: d00
    +
    31  use ctlblk_mod, only: lm, jsta_2l, jend_2u, jsta_m, jend_m, &
    +
    32  global, spval, im, jm, &
    +
    33  ista_2l, iend_2u, ista_m, iend_m
    +
    34  use gridspec_mod, only: gridtype
    +
    35  use upp_math, only: dvdxdudy, ddvdx, ddudy
    +
    36 
    +
    37  implicit none
    +
    38 
    +
    39 ! DECLARE VARIABLES.
    +
    40 !
    +
    41 ! LOGICAL RUN,FIRST,RESTRT,SIGMA,OLDRD,STRD
    +
    42  REAL, PARAMETER:: hlower=2000., hupper=5000.
    +
    43  REAL zmidloc
    +
    44  real :: r2dx, r2dy, dz, dcdx, dudy, dvdx
    +
    45  REAL :: htsfc(ista_2l:iend_2u,jsta_2l:jend_2u),updhel(ista_2l:iend_2u,jsta_2l:jend_2u)
    +
    46  integer :: l, j, i
    +
    47  INTEGER, dimension(jm) :: ihe,ihw
    +
    48 ! INTEGER DXVAL,DYVAL,CENLAT,CENLON,TRUELAT1,TRUELAT2
    +
    49 ! INTEGER LATSTART,LONSTART,LATLAST,LONLAST
    +
    50 !
    +
    51 !***************************************************************************
    +
    52 ! START CALUPDHEL HERE.
    +
    53 !
    +
    54 ! write(6,*) 'min/max WH(:,:,20):: ', minval(WH(:,:,20)), &
    +
    55 ! maxval(WH(:,:,20))
    +
    56 
    +
    57  DO l=1,lm
    +
    58  CALL exch(uh(ista_2l,jsta_2l,l))
    +
    59  END DO
    +
    60  IF (gridtype == 'B')THEN
    +
    61  DO l=1,lm
    +
    62  CALL exch(vh(ista_2l,jsta_2l,l))
    +
    63  END DO
    +
    64  END IF
    +
    65 !$omp parallel do private(i,j)
    66  DO j=jsta_2l,jend_2u
    -
    67  ihw(j) = -mod(j,2)
    -
    68  ihe(j) = ihw(j)+1
    -
    69  ENDDO
    -
    70 
    -
    71 ! Integrate (w * relative vorticity * dz) over the 2 km to
    -
    72 ! 5 km AGL depth.
    -
    73 
    -
    74 ! initial try without horizontal averaging
    -
    75 
    -
    76 !$omp parallel do private(i,j)
    -
    77  DO j=jsta_m,jend_m
    -
    78  DO i=ista_m,iend_m
    -
    79  htsfc(i,j) = zint(i,j,nint(lmh(i,j))+1)
    -
    80  ENDDO
    -
    81  ENDDO
    -
    82 
    +
    67  DO i=ista_2l,iend_2u
    +
    68  updhel(i,j) = d00
    +
    69  ENDDO
    +
    70  ENDDO
    +
    71 
    +
    72  DO j=jsta_2l,jend_2u
    +
    73  ihw(j) = -mod(j,2)
    +
    74  ihe(j) = ihw(j)+1
    +
    75  ENDDO
    +
    76 
    +
    77 ! Integrate (w * relative vorticity * dz) over the 2 km to
    +
    78 ! 5 km AGL depth.
    +
    79 
    +
    80 ! initial try without horizontal averaging
    +
    81 
    +
    82 !$omp parallel do private(i,j)
    83  DO j=jsta_m,jend_m
    84  DO i=ista_m,iend_m
    -
    85 
    -
    86  IF (htsfc(i,j) < spval) THEN
    -
    87 
    -
    88  r2dx = 1./(2.*dx(i,j))
    -
    89  r2dy = 1./(2.*dy(i,j))
    -
    90 
    -
    91  l_loop: DO l=1,lm
    -
    92  zmidloc = zmid(i,j,l)
    -
    93  IF (global) then ! will put in global algorithm later
    -
    94  updhel(i,j) = spval
    -
    95  EXIT l_loop
    -
    96  END IF
    -
    97 
    -
    98  IF ( (zmidloc - htsfc(i,j)) >= hlower .AND. &
    -
    99  (zmidloc - htsfc(i,j)) <= hupper ) THEN
    -
    100  dz=(zint(i,j,l)-zint(i,j,l+1))
    -
    101 
    -
    102  IF (wh(i,j,l) < 0) THEN
    +
    85  htsfc(i,j) = zint(i,j,nint(lmh(i,j))+1)
    +
    86  ENDDO
    +
    87  ENDDO
    +
    88 
    +
    89  DO j=jsta_m,jend_m
    +
    90  DO i=ista_m,iend_m
    +
    91 
    +
    92  IF (htsfc(i,j) < spval) THEN
    +
    93 
    +
    94  r2dx = 1./(2.*dx(i,j))
    +
    95  r2dy = 1./(2.*dy(i,j))
    +
    96 
    +
    97  l_loop: DO l=1,lm
    +
    98  zmidloc = zmid(i,j,l)
    +
    99  IF (global) then ! will put in global algorithm later
    +
    100  updhel(i,j) = spval
    +
    101  EXIT l_loop
    +
    102  END IF
    103 
    -
    104 ! ANY DOWNWARD MOTION IN 2-5 km LAYER KILLS COMPUTATION AND
    -
    105 ! SETS RESULTANT UPDRAFT HELICTY TO ZERO
    -
    106 
    -
    107  updhel(i,j) = 0.
    -
    108  EXIT l_loop
    +
    104  IF ( (zmidloc - htsfc(i,j)) >= hlower .AND. &
    +
    105  (zmidloc - htsfc(i,j)) <= hupper ) THEN
    +
    106  dz=(zint(i,j,l)-zint(i,j,l+1))
    +
    107 
    +
    108  IF (wh(i,j,l) < 0) THEN
    109 
    -
    110  ENDIF
    -
    111 
    -
    112  CALL dvdxdudy(uh(:,:,l),vh(:,:,l))
    -
    113  dvdx = ddvdx(i,j)
    -
    114  dudy = ddudy(i,j)
    +
    110 ! ANY DOWNWARD MOTION IN 2-5 km LAYER KILLS COMPUTATION AND
    +
    111 ! SETS RESULTANT UPDRAFT HELICTY TO ZERO
    +
    112 
    +
    113  updhel(i,j) = 0.
    +
    114  EXIT l_loop
    115 
    -
    116  updhel(i,j)=updhel(i,j)+(dvdx-dudy)*wh(i,j,l)*dz
    +
    116  ENDIF
    117 
    -
    118  ENDIF
    -
    119  ENDDO l_loop
    -
    120 
    -
    121  ELSE
    -
    122  updhel(i,j) = spval
    -
    123  ENDIF
    -
    124 
    -
    125  ENDDO
    -
    126  ENDDO
    +
    118  CALL dvdxdudy(uh(:,:,l),vh(:,:,l))
    +
    119  dvdx = ddvdx(i,j)
    +
    120  dudy = ddudy(i,j)
    +
    121 
    +
    122  updhel(i,j)=updhel(i,j)+(dvdx-dudy)*wh(i,j,l)*dz
    +
    123 
    +
    124  IF (updhel(i,j) < -9e10 .OR. updhel(i,j) > 9e10) THEN
    +
    125  updhel(i,j) = spval
    +
    126  ENDIF
    127 
    -
    128 !
    -
    129 ! print*,'jsta_m, jend_m in calupdhel= ',jsta_m,jend_m
    -
    130 !
    -
    131 ! END OF ROUTINE.
    -
    132 !
    -
    133  RETURN
    -
    134  END
    +
    128  ENDIF
    +
    129  ENDDO l_loop
    +
    130 
    +
    131  ELSE
    +
    132  updhel(i,j) = spval
    +
    133  ENDIF
    +
    134 
    +
    135  ENDDO
    +
    136  ENDDO
    +
    137 
    +
    138 !
    +
    139 ! print*,'jsta_m, jend_m in calupdhel= ',jsta_m,jend_m
    +
    140 !
    +
    141 ! END OF ROUTINE.
    +
    142 !
    +
    143  RETURN
    +
    144  END
    +
    ctlblk_mod
    Definition: CTLBLK.f:1
    +
    upp_math::dvdxdudy
    subroutine, public dvdxdudy(uwnd, vwnd)
    dvdxdudy() computes dudy, dvdx, uwnd
    Definition: UPP_MATH.f:54
    +
    calupdhel
    subroutine calupdhel(UPDHEL)
    Subroutine that computes the updraft helicity.
    Definition: CALUPDHEL.f:23
    masks
    Definition: MASKS_mod.f:1
    params_mod
    Definition: params.F:1
    - -
    upp_math
    dvdxdudy() computes dudy, dvdx, uwnd
    Definition: UPP_MATH.f:17
    + +
    upp_math
    Definition: UPP_MATH.f:19
    @@ -237,7 +246,7 @@
  • sorc
  • ncep_post.fd
  • CALUPDHEL.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5 diff --git a/CALWXT__BOURG_8f.html b/CALWXT__BOURG_8f.html index 334007d00..e14db7cc9 100644 --- a/CALWXT__BOURG_8f.html +++ b/CALWXT__BOURG_8f.html @@ -3,7 +3,7 @@ - + UPP: CALWXT_BOURG.f File Reference @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -109,19 +109,19 @@
    -

    Subroutine that calculate precipitation type (Bourgouin). +

    Subroutine that calculates precipitation type (Bourgouin). More...

    Go to the source code of this file.

    - + +

    Functions/Subroutines

    -subroutine calwxt_bourg_post (im, ista_2l, iend_2u, ista, iend, jm, jsta_2l, jend_2u, jsta, jend, lm, lp1, iseed, g, pthresh, t, q, pmid, pint, lmh, prec, zint, ptype, me)
    subroutine calwxt_bourg_post (im, ista_2l, iend_2u, ista, iend, jm, jsta_2l, jend_2u, jsta, jend, lm, lp1, iseed, g, pthresh, t, q, pmid, pint, lmh, prec, zint, ptype, me)
     calwxt_bourg_post Subroutine that calculates precipitation type (Bourgouin). More...
     

    Detailed Description

    -

    Subroutine that calculate precipitation type (Bourgouin).

    +

    Subroutine that calculates precipitation type (Bourgouin).

    This routine computes precipitation type. using a decision tree approach that uses the so-called "energy method" of Bourgouin of AES (Canada) 1992.

    Parameters
    @@ -153,7 +153,8 @@ ptype=2 ice pellets/mix with ice pellets ptype=4 freezing rain/mix with freezing rain ptype=8 rain - + +
    [in]meinteger Identifier for the processor used in the current instance.
    @@ -179,7 +180,201 @@

    Program history log:

    Date
    1999-07-06

    Definition in file CALWXT_BOURG.f.

    -
    +

    Function/Subroutine Documentation

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine calwxt_bourg_post (integer, intent(in) im,
    integer, intent(in) ista_2l,
    integer, intent(in) iend_2u,
    integer, intent(in) ista,
    integer, intent(in) iend,
    integer, intent(in) jm,
    integer, intent(in) jsta_2l,
    integer, intent(in) jend_2u,
    integer, intent(in) jsta,
    integer, intent(in) jend,
    integer, intent(in) lm,
    integer, intent(in) lp1,
    integer, intent(in) iseed,
    real, intent(in) g,
    real, intent(in) pthresh,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(in) t,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(in) q,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(in) pmid,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lp1), intent(in) pint,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) lmh,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) prec,
    real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lp1), intent(in) zint,
    integer, dimension(ista:iend,jsta:jend), intent(out) ptype,
    integer, intent(in) me 
    )
    +
    + +

    calwxt_bourg_post Subroutine that calculates precipitation type (Bourgouin).

    +
    Parameters
    + + + + + + + + + + + + + + + + + + + + + + + + + +
    [in]iminteger i dimension.
    [in]ista_2linteger i dimension start point (including haloes).
    [in]iend_2uinteger i dimension end point (including haloes).
    [in]istainteger i dimension start point (excluding haloes).
    [in]iendinteger i dimension end point (excluding haloes).
    [in]jminteger j dimension.
    [in]jsta_2linteger j dimension start point (including haloes).
    [in]jend_2uinteger j dimension end point (including haloes).
    [in]jstainteger j dimension start point (excluding haloes).
    [in]jendinteger j dimension end point (excluding haloes).
    [in]lminteger k dimension.
    [in]lp1integer k dimension plus 1.
    [in]iseedinteger random number seed.
    [in]greal gravity (m/s**2).
    [in]pthreshreal precipitation threshold (m).
    [in]treal(im,jsta_2l:jend_2u,lm) mid layer temp (K).
    [in]qreal(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg).
    [in]pmidreal(im,jsta_2l:jend_2u,lm) mid layer pressure (Pa).
    [in]pintreal(im,jsta_2l:jend_2u,lp1) interface pressure (Pa).
    [in]lmhreal(im,jsta_2l:jend_2u) max number of layers.
    [in]precreal(im,jsta_2l:jend_2u) precipitation (m).
    [in]zintreal(im,jsta_2l:jend_2u,lp1) interface height (m).
    [out]ptypeinteger(im,jm) instantaneous weather type () acts like a 4 bit binary 1111 = rain/freezing rain/ice pellets/snow.
    [in]meinteger Identifier for the processor used in the current instance.
    +
    +
    + +

    Definition at line 82 of file CALWXT_BOURG.f.

    + +

    Referenced by surfce().

    + +
    +
    + diff --git a/CALWXT__BOURG_8f_source.html b/CALWXT__BOURG_8f_source.html index c272950ec..7b02d87cb 100644 --- a/CALWXT__BOURG_8f_source.html +++ b/CALWXT__BOURG_8f_source.html @@ -3,7 +3,7 @@ - + UPP: CALWXT_BOURG.f Source File @@ -30,7 +30,7 @@
    UPP -  V11.0.0 +  11.0.0
    @@ -38,7 +38,7 @@ - + @@ -92,7 +92,7 @@ onmouseover="return searchBox.OnSearchSelectShow()" onmouseout="return searchBox.OnSearchSelectHide()" onkeydown="return searchBox.OnSearchSelectKey(event)"> - All Data Structures Files Functions Pages + All Data Structures Files Functions Variables Pages
    @@ -107,216 +107,219 @@
    Go to the documentation of this file.
    1 
    -
    53 
    -
    54  subroutine calwxt_bourg_post(im,ista_2l,iend_2u,ista,iend,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, &
    -
    55  & iseed,g,pthresh, &
    -
    56  & t,q,pmid,pint,lmh,prec,zint,ptype,me)
    -
    57  implicit none
    -
    58 !
    -
    59 ! input:
    -
    60  integer,intent(in):: im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,iseed,me,&
    -
    61  ista_2l,iend_2u,ista,iend
    -
    62  real,intent(in):: g,pthresh
    -
    63  real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm) :: t, q, pmid
    -
    64  real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lp1) :: pint, zint
    -
    65  real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: lmh, prec
    -
    66 !
    -
    67 ! output:
    -
    68 ! real,intent(out) :: ptype(im,jm)
    -
    69  integer,intent(out) :: ptype(ista:iend,jsta:jend)
    -
    70 !
    -
    71  integer i,j,ifrzl,iwrml,l,lhiwrm,lmhk,jlen
    -
    72  real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2
    -
    73  real rn(im*jm*2)
    -
    74  integer :: rn_seed_size
    -
    75  integer, allocatable, dimension(:) :: rn_seed
    -
    76  logical, parameter :: debugprint = .false.
    -
    77 !
    -
    78 ! initialize weather type array to zero (ie, off).
    -
    79 ! we do this since we want ptype to represent the
    -
    80 ! instantaneous weather type on return.
    -
    81  if (debugprint) then
    -
    82  print *,'in calwxtbg, jsta,jend=',jsta,jend,' im=',im
    -
    83  print *,'in calwxtbg,me=',me,'iseed=',iseed
    -
    84  endif
    -
    85 !
    -
    86 !$omp parallel do
    -
    87  do j=jsta,jend
    -
    88  do i=ista,iend
    -
    89  ptype(i,j) = 0
    -
    90  enddo
    -
    91  enddo
    -
    92 !
    -
    93  jlen = jend - jsta + 1
    -
    94 
    -
    95  call random_seed(size = rn_seed_size)
    -
    96  allocate(rn_seed(rn_seed_size))
    -
    97  rn_seed = iseed
    -
    98  call random_seed(put = rn_seed)
    -
    99  call random_number(rn)
    -
    100 !
    -
    101 !!$omp parallel do &
    -
    102 ! & private(a,lmhk,tlmhk,iwrml,psfck,lhiwrm,pintk1,pintk2,area1, &
    -
    103 ! & areape,dzkl,surfw,r1,r2)
    -
    104 ! print *,'incalwxtbg, rn',maxval(rn),minval(rn)
    -
    105 
    -
    106  do j=jsta,jend
    -
    107 ! if(me==1)print *,'incalwxtbg, j=',j
    -
    108  do i=ista,iend
    -
    109  lmhk = min(nint(lmh(i,j)),lm)
    -
    110  psfck = pint(i,j,lmhk+1)
    -
    111 !
    -
    112  if (prec(i,j) <= pthresh) cycle ! skip this point if no precip this time step
    -
    113 
    -
    114 ! find the depth of the warm layer based at the surface
    -
    115 ! this will be the cut off point between computing
    -
    116 ! the surface based warm air and the warm air aloft
    -
    117 !
    -
    118  tlmhk = t(i,j,lmhk) ! lowest layer t
    -
    119  iwrml = lmhk + 1
    -
    120  if (tlmhk >= 273.15) then
    -
    121  do l = lmhk, 2, -1
    -
    122  if (t(i,j,l) >= 273.15 .and. t(i,j,l-1) < 273.15 .and. &
    -
    123  & iwrml == lmhk+1) iwrml = l
    -
    124  end do
    -
    125  end if
    -
    126 !
    -
    127 ! now find the highest above freezing level
    -
    128 !
    -
    129 ! gsm added 250 mb check to prevent stratospheric warming situations
    -
    130 ! from counting as warm layers aloft
    -
    131  lhiwrm = lmhk + 1
    -
    132  do l = lmhk, 1, -1
    -
    133  if (t(i,j,l) >= 273.15 .and. pmid(i,j,l) > 25000.) lhiwrm = l
    -
    134  end do
    -
    135 
    -
    136 ! energy variables
    -
    137 
    -
    138 ! surfw is the positive energy between ground and the first sub-freezing layer above ground
    -
    139 ! areane is the negative energy between ground and the highest layer above ground
    -
    140 ! that is above freezing
    -
    141 ! areape is the positive energy "aloft" which is the warm energy not based at the ground
    -
    142 ! (the total warm energy = surfw + areape)
    -
    143 !
    -
    144 ! pintk1 is the pressure at the bottom of the layer
    -
    145 ! pintk2 is the pressure at the top of the layer
    -
    146 ! dzkl is the thickness of the layer
    -
    147 ! ifrzl is a flag that tells us if we have hit a below freezing layer
    -
    148 !
    -
    149  pintk1 = psfck
    -
    150  ifrzl = 0
    -
    151  areane = 0.0
    -
    152  areape = 0.0
    -
    153  surfw = 0.0
    -
    154 
    -
    155  do l = lmhk, 1, -1
    -
    156  if (ifrzl == 0.and.t(i,j,l) <= 273.15) ifrzl = 1
    -
    157  pintk2 = pint(i,j,l)
    -
    158  dzkl = zint(i,j,l)-zint(i,j,l+1)
    -
    159  area1 = log(t(i,j,l)/273.15) * g * dzkl
    -
    160  if (t(i,j,l) >= 273.15.and. pmid(i,j,l) > 25000.) then
    -
    161  if (l < iwrml) areape = areape + area1
    -
    162  if (l >= iwrml) surfw = surfw + area1
    -
    163  else
    -
    164  if (l > lhiwrm) areane = areane + abs(area1)
    -
    165  end if
    -
    166  pintk1 = pintk2
    -
    167  end do
    -
    168 !
    -
    169 ! decision tree time
    -
    170 !
    -
    171  if (areape < 2.0) then
    -
    172 ! very little or no positive energy aloft, check for
    -
    173 ! positive energy just above the surface to determine rain vs. snow
    -
    174  if (surfw < 5.6) then
    -
    175 ! not enough positive energy just above the surface
    -
    176 ! snow = 1
    -
    177  ptype(i,j) = 1
    -
    178  else if (surfw > 13.2) then
    -
    179 ! enough positive energy just above the surface
    -
    180 ! rain = 8
    -
    181  ptype(i,j) = 8
    -
    182  else
    -
    183 ! transition zone, assume equally likely rain/snow
    -
    184 ! picking a random number, if <=0.5 snow
    -
    185  r1 = rn(i+im*(j-1))
    -
    186  if (r1 <= 0.5) then
    -
    187  ptype(i,j) = 1 ! snow = 1
    -
    188  else
    -
    189  ptype(i,j) = 8 ! rain = 8
    -
    190  end if
    -
    191  end if
    -
    192 !
    -
    193  else
    -
    194 ! some positive energy aloft, check for enough negative energy
    -
    195 ! to freeze and make ice pellets to determine ip vs. zr
    -
    196  if (areane > 66.0+0.66*areape) then
    -
    197 ! enough negative area to make ip,
    -
    198 ! now need to check if there is enough positive energy
    -
    199 ! just above the surface to melt ip to make rain
    -
    200  if (surfw < 5.6) then
    -
    201 ! not enough energy at the surface to melt ip
    -
    202  ptype(i,j) = 2 ! ice pellets = 2
    -
    203  else if (surfw > 13.2) then
    -
    204 ! enough energy at the surface to melt ip
    -
    205  ptype(i,j) = 8 ! rain = 8
    -
    206  else
    -
    207 ! transition zone, assume equally likely ip/rain
    -
    208 ! picking a random number, if <=0.5 ip
    -
    209  r1 = rn(i+im*(j-1))
    -
    210  if (r1 <= 0.5) then
    -
    211  ptype(i,j) = 2 ! ice pellets = 2
    -
    212  else
    -
    213  ptype(i,j) = 8 ! rain = 8
    -
    214  end if
    -
    215  end if
    -
    216  else if (areane < 46.0+0.66*areape) then
    -
    217 ! not enough negative energy to refreeze, check surface temp
    -
    218 ! to determine rain vs. zr
    -
    219  if (tlmhk < 273.15) then
    -
    220  ptype(i,j) = 4 ! freezing rain = 4
    -
    221  else
    -
    222  ptype(i,j) = 8 ! rain = 8
    -
    223  end if
    -
    224  else
    -
    225 ! transition zone, assume equally likely ip/zr
    -
    226 ! picking a random number, if <=0.5 ip
    -
    227  r1 = rn(i+im*(j-1))
    -
    228  if (r1 <= 0.5) then
    -
    229 ! still need to check positive energy
    -
    230 ! just above the surface to melt ip vs. rain
    -
    231  if (surfw < 5.6) then
    -
    232  ptype(i,j) = 2 ! ice pellets = 2
    -
    233  else if (surfw > 13.2) then
    -
    234  ptype(i,j) = 8 ! rain = 8
    -
    235  else
    -
    236 ! transition zone, assume equally likely ip/rain
    -
    237 ! picking a random number, if <=0.5 ip
    -
    238  r2 = rn(i+im*(j-1)+im*jm)
    -
    239  if (r2 <= 0.5) then
    -
    240  ptype(i,j) = 2 ! ice pellets = 2
    -
    241  else
    -
    242  ptype(i,j) = 8 ! rain = 8
    -
    243  end if
    -
    244  end if
    -
    245  else
    -
    246 ! not enough negative energy to refreeze, check surface temp
    -
    247 ! to determine rain vs. zr
    -
    248  if (tlmhk < 273.15) then
    -
    249  ptype(i,j) = 4 ! freezing rain = 4
    -
    250  else
    -
    251  ptype(i,j) = 8 ! rain = 8
    -
    252  end if
    -
    253  end if
    -
    254  end if
    -
    255  end if
    -
    256 ! write(1000+me,*)' finished for i, j, from calbourge me=',me,i,j
    -
    257  end do
    -
    258 ! write(1000+me,*)' finished for j, from calbourge me=',me,j
    -
    259  end do
    -
    260 ! write(1000+me,*)' returning from calbourge me=',me
    -
    261  return
    -
    262  end
    +
    54 !--------------------------------------------------------------------------------------
    +
    81 !------------------------------------------------------------------------------------------------------------
    +
    82  subroutine calwxt_bourg_post(im,ista_2l,iend_2u,ista,iend,jm, &
    +
    83  & jsta_2l,jend_2u,jsta,jend,lm,lp1, &
    +
    84  & iseed,g,pthresh, &
    +
    85  & t,q,pmid,pint,lmh,prec,zint,ptype,me)
    +
    86  implicit none
    +
    87 !
    +
    88 ! input:
    +
    89  integer,intent(in):: im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,iseed,me,&
    +
    90  ista_2l,iend_2u,ista,iend
    +
    91  real,intent(in):: g,pthresh
    +
    92  real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm) :: t, q, pmid
    +
    93  real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lp1) :: pint, zint
    +
    94  real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: lmh, prec
    +
    95 !
    +
    96 ! output:
    +
    97 ! real,intent(out) :: ptype(im,jm)
    +
    98  integer,intent(out) :: ptype(ista:iend,jsta:jend)
    +
    99 !
    +
    100  integer i,j,ifrzl,iwrml,l,lhiwrm,lmhk,jlen
    +
    101  real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2
    +
    102  real rn(im*jm*2)
    +
    103  integer :: rn_seed_size
    +
    104  integer, allocatable, dimension(:) :: rn_seed
    +
    105  logical, parameter :: debugprint = .false.
    +
    106 !
    +
    107 ! initialize weather type array to zero (ie, off).
    +
    108 ! we do this since we want ptype to represent the
    +
    109 ! instantaneous weather type on return.
    +
    110  if (debugprint) then
    +
    111  print *,'in calwxtbg, jsta,jend=',jsta,jend,' im=',im
    +
    112  print *,'in calwxtbg,me=',me,'iseed=',iseed
    +
    113  endif
    +
    114 !
    +
    115 !$omp parallel do
    +
    116  do j=jsta,jend
    +
    117  do i=ista,iend
    +
    118  ptype(i,j) = 0
    +
    119  enddo
    +
    120  enddo
    +
    121 !
    +
    122  jlen = jend - jsta + 1
    +
    123 
    +
    124  call random_seed(size = rn_seed_size)
    +
    125  allocate(rn_seed(rn_seed_size))
    +
    126  rn_seed = iseed
    +
    127  call random_seed(put = rn_seed)
    +
    128  call random_number(rn)
    +
    129 !
    +
    130 !!$omp parallel do &
    +
    131 ! & private(a,lmhk,tlmhk,iwrml,psfck,lhiwrm,pintk1,pintk2,area1, &
    +
    132 ! & areape,dzkl,surfw,r1,r2)
    +
    133 ! print *,'incalwxtbg, rn',maxval(rn),minval(rn)
    +
    134 
    +
    135  do j=jsta,jend
    +
    136 ! if(me==1)print *,'incalwxtbg, j=',j
    +
    137  do i=ista,iend
    +
    138  lmhk = min(nint(lmh(i,j)),lm)
    +
    139  psfck = pint(i,j,lmhk+1)
    +
    140 !
    +
    141  if (prec(i,j) <= pthresh) cycle ! skip this point if no precip this time step
    +
    142 
    +
    143 ! find the depth of the warm layer based at the surface
    +
    144 ! this will be the cut off point between computing
    +
    145 ! the surface based warm air and the warm air aloft
    +
    146 !
    +
    147  tlmhk = t(i,j,lmhk) ! lowest layer t
    +
    148  iwrml = lmhk + 1
    +
    149  if (tlmhk >= 273.15) then
    +
    150  do l = lmhk, 2, -1
    +
    151  if (t(i,j,l) >= 273.15 .and. t(i,j,l-1) < 273.15 .and. &
    +
    152  & iwrml == lmhk+1) iwrml = l
    +
    153  end do
    +
    154  end if
    +
    155 !
    +
    156 ! now find the highest above freezing level
    +
    157 !
    +
    158 ! gsm added 250 mb check to prevent stratospheric warming situations
    +
    159 ! from counting as warm layers aloft
    +
    160  lhiwrm = lmhk + 1
    +
    161  do l = lmhk, 1, -1
    +
    162  if (t(i,j,l) >= 273.15 .and. pmid(i,j,l) > 25000.) lhiwrm = l
    +
    163  end do
    +
    164 
    +
    165 ! energy variables
    +
    166 
    +
    167 ! surfw is the positive energy between ground and the first sub-freezing layer above ground
    +
    168 ! areane is the negative energy between ground and the highest layer above ground
    +
    169 ! that is above freezing
    +
    170 ! areape is the positive energy "aloft" which is the warm energy not based at the ground
    +
    171 ! (the total warm energy = surfw + areape)
    +
    172 !
    +
    173 ! pintk1 is the pressure at the bottom of the layer
    +
    174 ! pintk2 is the pressure at the top of the layer
    +
    175 ! dzkl is the thickness of the layer
    +
    176 ! ifrzl is a flag that tells us if we have hit a below freezing layer
    +
    177 !
    +
    178  pintk1 = psfck
    +
    179  ifrzl = 0
    +
    180  areane = 0.0
    +
    181  areape = 0.0
    +
    182  surfw = 0.0
    +
    183 
    +
    184  do l = lmhk, 1, -1
    +
    185  if (ifrzl == 0.and.t(i,j,l) <= 273.15) ifrzl = 1
    +
    186  pintk2 = pint(i,j,l)
    +
    187  dzkl = zint(i,j,l)-zint(i,j,l+1)
    +
    188  area1 = log(t(i,j,l)/273.15) * g * dzkl
    +
    189  if (t(i,j,l) >= 273.15.and. pmid(i,j,l) > 25000.) then
    +
    190  if (l < iwrml) areape = areape + area1
    +
    191  if (l >= iwrml) surfw = surfw + area1
    +
    192  else
    +
    193  if (l > lhiwrm) areane = areane + abs(area1)
    +
    194  end if
    +
    195  pintk1 = pintk2
    +
    196  end do
    +
    197 !
    +
    198 ! decision tree time
    +
    199 !
    +
    200  if (areape < 2.0) then
    +
    201 ! very little or no positive energy aloft, check for
    +
    202 ! positive energy just above the surface to determine rain vs. snow
    +
    203  if (surfw < 5.6) then
    +
    204 ! not enough positive energy just above the surface
    +
    205 ! snow = 1
    +
    206  ptype(i,j) = 1
    +
    207  else if (surfw > 13.2) then
    +
    208 ! enough positive energy just above the surface
    +
    209 ! rain = 8
    +
    210  ptype(i,j) = 8
    +
    211  else
    +
    212 ! transition zone, assume equally likely rain/snow
    +
    213 ! picking a random number, if <=0.5 snow
    +
    214  r1 = rn(i+im*(j-1))
    +
    215  if (r1 <= 0.5) then
    +
    216  ptype(i,j) = 1 ! snow = 1
    +
    217  else
    +
    218  ptype(i,j) = 8 ! rain = 8
    +
    219  end if
    +
    220  end if
    +
    221 !
    +
    222  else
    +
    223 ! some positive energy aloft, check for enough negative energy
    +
    224 ! to freeze and make ice pellets to determine ip vs. zr
    +
    225  if (areane > 66.0+0.66*areape) then
    +
    226 ! enough negative area to make ip,
    +
    227 ! now need to check if there is enough positive energy
    +
    228 ! just above the surface to melt ip to make rain
    +
    229  if (surfw < 5.6) then
    +
    230 ! not enough energy at the surface to melt ip
    +
    231  ptype(i,j) = 2 ! ice pellets = 2
    +
    232  else if (surfw > 13.2) then
    +
    233 ! enough energy at the surface to melt ip
    +
    234  ptype(i,j) = 8 ! rain = 8
    +
    235  else
    +
    236 ! transition zone, assume equally likely ip/rain
    +
    237 ! picking a random number, if <=0.5 ip
    +
    238  r1 = rn(i+im*(j-1))
    +
    239  if (r1 <= 0.5) then
    +
    240  ptype(i,j) = 2 ! ice pellets = 2
    +
    241  else
    +
    242  ptype(i,j) = 8 ! rain = 8
    +
    243  end if
    +
    244  end if
    +
    245  else if (areane < 46.0+0.66*areape) then
    +
    246 ! not enough negative energy to refreeze, check surface temp
    +
    247 ! to determine rain vs. zr
    +
    248  if (tlmhk < 273.15) then
    +
    249  ptype(i,j) = 4 ! freezing rain = 4
    +
    250  else
    +
    251  ptype(i,j) = 8 ! rain = 8
    +
    252  end if
    +
    253  else
    +
    254 ! transition zone, assume equally likely ip/zr
    +
    255 ! picking a random number, if <=0.5 ip
    +
    256  r1 = rn(i+im*(j-1))
    +
    257  if (r1 <= 0.5) then
    +
    258 ! still need to check positive energy
    +
    259 ! just above the surface to melt ip vs. rain
    +
    260  if (surfw < 5.6) then
    +
    261  ptype(i,j) = 2 ! ice pellets = 2
    +
    262  else if (surfw > 13.2) then
    +
    263  ptype(i,j) = 8 ! rain = 8
    +
    264  else
    +
    265 ! transition zone, assume equally likely ip/rain
    +
    266 ! picking a random number, if <=0.5 ip
    +
    267  r2 = rn(i+im*(j-1)+im*jm)
    +
    268  if (r2 <= 0.5) then
    +
    269  ptype(i,j) = 2 ! ice pellets = 2
    +
    270  else
    +
    271  ptype(i,j) = 8 ! rain = 8
    +
    272  end if
    +
    273  end if
    +
    274  else
    +
    275 ! not enough negative energy to refreeze, check surface temp
    +
    276 ! to determine rain vs. zr
    +
    277  if (tlmhk < 273.15) then
    +
    278  ptype(i,j) = 4 ! freezing rain = 4
    +
    279  else
    +
    280  ptype(i,j) = 8 ! rain = 8
    +
    281  end if
    +
    282  end if
    +
    283  end if
    +
    284  end if
    +
    285 ! write(1000+me,*)' finished for i, j, from calbourge me=',me,i,j
    +
    286  end do
    +
    287 ! write(1000+me,*)' finished for j, from calbourge me=',me,j
    +
    288  end do
    +
    289 ! write(1000+me,*)' returning from calbourge me=',me
    +
    290  return
    +
    291  end
    +
    calwxt_bourg_post
    subroutine calwxt_bourg_post(im, ista_2l, iend_2u, ista, iend, jm, jsta_2l, jend_2u, jsta, jend, lm, lp1, iseed, g, pthresh, t, q, pmid, pint, lmh, prec, zint, ptype, me)
    calwxt_bourg_post Subroutine that calculates precipitation type (Bourgouin).
    Definition: CALWXT_BOURG.f:82
    @@ -325,7 +328,7 @@
  • sorc
  • ncep_post.fd
  • CALWXT_BOURG.f
  • Generated by - doxygen 1.8.6
    • + doxygen 1.8.5