module mod_domain3d

  use mod_types !Fortran Modul mit der Typedefiniton für Real und Integer
  use, intrinsic :: ISO_C_BINDING !C-Binding

  implicit none
  !Gitterdefinition mit den Distributionsparametern
  type, bind(c) :: type_dom
    integer(kind=ik) :: num_ii !Anzahl der inneren Gebietszellen in Y-Richtung
    integer(kind=ik) :: num_jj !Anzahl der inneren Gebietszellen in X-Richtung
    integer(kind=ik) :: num_kk !Anzahl der inneren Gebietszellen in Z-Richtung
    integer(kind=ik) :: num_blk_ii !Anzahl der Bloecke in Y-Richtung
    integer(kind=ik) :: num_blk_jj !Anzahl der Bloecke in X-Richtung
    integer(kind=ik) :: num_blk_kk !Anzahl der Bloecke in Z-Richtung
    integer(kind=ik) :: blk_num_ii !Anzahl der inneren Blockzellen in Y-Richtung
    integer(kind=ik) :: blk_num_jj !Anzahl der inneren Blockzellen in X-Richtung
    integer(kind=ik) :: blk_num_kk !Anzahl der inneren Blockzellen in Z-Richtung
  end type type_dom

end module mod_domain3d


      SUBROUTINE PIELBL(LABELS,NLABLS)
C
C          ------------------------------------------------
C          ROUTINE NO. (  87)   VERSION (A8.3)    20:JAN:92
C                         === FORTRAN-77 ===
C          ------------------------------------------------
C
C          THIS LABELS ALL THE SECTORS OF A PIECHART.
C
C          THE ARGUMENTS ARE AS FOLLOWS:
C
C          [LABELS] CONTAINS THE LABELS TO BE WRITTEN ON THE SECTORS.
C          <NLABLS> IS THE NUMBER OF LABELS.
C
C
      LOGICAL ERRON
      CHARACTER LABELS(NLABLS)*(*)
C
      COMMON /T0ACON/ ANGCON
      COMMON /T0CANG/ STANG0,CRANG0
      COMMON /T0CDIM/ MAGN0,OBLAT0
      COMMON /T0CSPA/ X1CHR0,X2CHR0,Y1CHR0,Y2CHR0
      COMMON /T0KLAB/ LABCL0(100),LENLAB
      COMMON /T0LATT/ KOLIN0,ITHIK0
      COMMON /T0MAPP/ X1MAP0,X2MAP0,Y1MAP0,Y2MAP0
      COMMON /T0PIAN/ ANGPIE
      COMMON /T0PIE/  XCPIE,YCPIE,PIEVAL(50),NPVALS,PIERAD,PIETOT,SIZLIM
      COMMON /T0PILM/ MPIELB
      COMMON /T0PPOS/ XPLOT0,YPLOT0
      COMMON /T0TRAC/ IPRINT
      COMMON /T3CONS/ PI
      COMMON /T3ERRS/ ERRON,NUMERR
C
C
      IF (IPRINT.EQ.1) CALL G0MESG(137,0)
      IF (NLABLS.LE.0) RETURN
      IF (NPVALS.GT.50) GO TO 901
      IF (NLABLS.NE.NPVALS) GO TO 902
C
      IPRSAV= IPRINT
      IPRINT= 0
      XSAVE= XPLOT0
      YSAVE= YPLOT0
      KOLLSV= KOLIN0
      KOLLIN= 1
      ORSAVE= STANG0/ANGCON
      MAGSAV= MAGN0
      NCHRS= LEN(LABELS(1))
      YSCALE= (Y2MAP0-Y1MAP0)/(X2MAP0-X1MAP0)
      XCSAV1= X1CHR0
      XCSAV2= X2CHR0
      YCSAV1= Y1CHR0
      YCSAV2= Y2CHR0
      CALL CSPACE(0.0,0.0,0.0,0.0)
      IF (MPIELB.GT.1) GO TO 1
C
      CALL CTRORI(0.0)
      SIZE= AMIN1(0.17,SIZLIM)*ABS(YSCALE)/SQRT(NCHRS*OBLAT0)
      CALL CTRSIZ(SIZE*PIERAD)
    1 ADANGL= ANGPIE
C
      DO 100 LCOUNT= 1,NLABLS
        ANGLE= ABS(PIEVAL(LCOUNT))*PIETOT
        ANGLAB= ANGLE*0.5+ADANGL
        ADANGL= ADANGL+ANGLE
        COSLAB= COS(ANGLAB)
        SINLAB= SIN(ANGLAB)*YSCALE
        TEST= COSLAB*(X2MAP0-X1MAP0)
        OFFSET= 0.0
        IF (PIEVAL(LCOUNT).LT.0.0) OFFSET= 0.1
C
        RAD= PIERAD*(0.85+OFFSET)
        RX= RAD*COSLAB+XCPIE
        RY= RAD*SINLAB+YCPIE
        IF (LENLAB.GT.0) CALL LINCOL(LABCL0(KOLLIN))
C
        KOLLIN= KOLLIN+1
        IF (KOLLIN.GT.LENLAB) KOLLIN= 1
C
        DO 200 ICHAR= 1,NCHRS
          NCHARS= NCHRS-ICHAR+1
          IF (LABELS(LCOUNT)(NCHARS:NCHARS).NE.' ') GO TO 2
  200   CONTINUE
C
    2   NCHARS= NCHRS-NCHARS
        CALL POSITN(RX,RY)
        IF (MPIELB.GT.1) GO TO 4
        IF (COSLAB.GE.0.0) CALL CTRORI(ANGLAB/ANGCON)
        IF (COSLAB.LT.0.0) CALL CTRORI((ANGLAB-PI)/ANGCON)
        IF (TEST.LT.0.0) GO TO 3
C
        CALL SPACE(NCHARS-1)
        CALL TCSEND(LABELS(LCOUNT))
        GO TO 100
C
    3   CALL TYPECS(LABELS(LCOUNT))
        GO TO 100
C
    4   RX= RX+0.25*PIERAD*COSLAB
        RY= RY+0.25*PIERAD*SINLAB
        CALL JOIN(RX,RY)
        RX= RX+0.15*PIERAD*SIGN(1.0,COSLAB)
        CALL JOIN(RX,RY)
        IF (TEST.LT.0.0) GO TO 5
C
        CALL SPACE(1)
        CALL TYPECS(LABELS(LCOUNT))
        GO TO 100
C
    5   CALL SPACE(NCHARS)
        CALL TCSEND(LABELS(LCOUNT))
  100 CONTINUE
C
      CALL LINCOL(KOLLSV)
      CALL POSITN(XSAVE,YSAVE)
      CALL CTRORI(ORSAVE)
      CALL CTRMAG(MAGSAV)
      CALL CSPACE(XCSAV1,XCSAV2,YCSAV1,YCSAV2)
      IPRINT= IPRSAV
C
      RETURN
C
  901 NUMERR= 25
      GO TO 903
C
  902 NUMERR= 26
  903 IF (ERRON) CALL G0ERMS
C
      RETURN
      END


      SUBROUTINE EM3D (ELTYPE,ISTART,ITYPE,NCOUNT,IDO,IWORDS,NBDYS,ALL,
     1                 NELOUT)
C
C     E  AND  M LOADS FOR 3-D ELEMENTS
C     TETRA  39   WEDGE  40   HEXA1 41  HEXA2  42
C     IHEX1  65   IHEX2  66   IHEX3 67
C
      LOGICAL         ONLYC
      INTEGER         SCR6,ALL,TYPOLD,ELID,
     1                ELTYPE,OUTPT,SYSBUF,POINTR(7,7),FRSTGD,TMAP(88)
      REAL            LL(4,5),W(5)
      DIMENSION       ISC(5),SC(5),XLACC(3),BUF(50),IBUF(50),HCX3(60),
     1                HCX(4),HCY(4),HCZ(4),
     2                G(9),NECPT(1),DR(24),IZ(1),IP(4),R(3,8),XLOAD(8),
     3                GPT(32),BXYZ(3,32),S(4),H(4),GAUSS(8),F(32),
     4                SHP(32),DSHP(3,32),XJACOB(3,3),DSHPB(3,32),HC(96),
     5                HCXYZ(3),GH(3)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /SYSTEM/ KSYSTM(2)
      COMMON /ZZZZZZ/ Z(1)
      COMMON /EMECPT/ ECPT(200)
      COMMON /MATIN / MATID,INFLAG,ELTEMP
      COMMON /HMTOUT/ XMAT(6)
      EQUIVALENCE     (KSYSTM(1),SYSBUF), (KSYSTM(2),OUTPT),
     1                (ECPT(1),NECPT(1)), (Z(1),IZ(1)), (I1,IP(1)),
     2                (I2,IP(2)),(I3,IP(3)), (I4,IP(4))
      EQUIVALENCE     (BUF(1),IBUF(1))  , (ISC(1),SC(1))
C
C     GRID POINT NO FOR EACH ELEMENT
C
      DATA    TMAP  / 1, 2, 3, 4,    1, 2, 3, 5,    1, 2, 3, 6,
     1                1, 4, 5, 6,    2, 4, 5, 6,    3, 4, 5, 6,
     2                1, 2, 4, 6,    2, 3, 4, 6,    1, 3, 4, 5,
     3                2, 3, 4, 5,    1, 3, 5, 6,    1, 2, 5, 6,
     4                1, 2, 3, 6,    1, 3, 4, 8,    1, 3, 8, 6,
     5                1, 5, 6, 8,    3, 6, 7, 8,    2, 3, 4, 7,
     6                1, 2, 4, 5,    2, 4, 5, 7,    2, 5, 6, 7,
     7                4, 5, 7, 8/
C     DATA    NAM   / 4HEM3D,4H       /
      DATA    TYPOLD/ 0               /
      DATA    SCR6  / 306             /
C
C     SET UP GAUSSIAN INTEGRATION POINTS
C
      DATA    GAUSS / 0.57735027,     0.55555556,
     1                0.77459667,     0.88888889,
     2                0.34785484,     0.86113631,
     3                0.65214515,     0.33998104/
C
C     SET UP POINTR ARRAY ONTO EST
C
C                    TYPE  MID   FRSTGD  ISYS1   NIP     ITEMP     NELS
      DATA    POINTR/ 39,   2,    3    ,  7,      0,      23,       1,
     1                40,   2,    3,      9,      0,      33,      12,
     2                41,   2,    3,      11,     0,      43,       5,
     3                42,   2,    3,      11,     0,      43,       10,
     4                65,   10,   2,      16,     12,     48,       1,
     5                66,   22,   2,      28,     24,     108,      1,
     6                67,   34,   2,      40,     36,     168,      1 /
C
C
      ONLYC  =.FALSE.
      NOPTS  = 6
      IF (ELTYPE .EQ. TYPOLD) GO TO 30
      TYPOLD = ELTYPE
      DO 10 L = 1,7
      ILIS   = L
      IF (ELTYPE-POINTR(1,L)) 1200,20,10
   10 CONTINUE
      GO TO 1200
C
C     SET UPPOINTERS INTO EST(ECPT) DATA
C
   20 MID = POINTR(2,ILIS)
C
C     MATERIAL ID
C
      FRSTGD = POINTR(3,ILIS)
C
C     FIRST SIL
C
      ISYS1 = POINTR(4,ILIS)
C
C     FIRST CSIL
C
      NIP = POINTR(5,ILIS)
C
C     NO OF INTEGRATION POINTS (ISOPARAMETRICS ONLY)
C
      ITEMP = POINTR(6,ILIS)
C
C     TEMPERATURE DATA
C
      NELS = POINTR(7,ILIS)
C
C     NO. OF ELEMENTS
C
C     GO TO SECTION 190 FOR ISOPARAMETRICS
C
C     CHECK FOR ZERO LOAD
C
   30 NGRID = ISYS1 - FRSTGD
      IF (ELTYPE .GE. 65) NGRID = NGRID - 6
C                     65 TO 67 ??
      ISC(1) = NECPT(1)
      ISC(2) = 1
      IF (ELTYPE .EQ. 65) ISC(2) = 9
      IF (ELTYPE.EQ.66 .OR. ELTYPE.EQ.67) ISC(2) = 21
C
C     CHECK TO SEE IF THIS ELEMENT CONTAINS A GRID POINT ON A PERMBDY
C     CARD. IF SO, OR IF NO PERMBDY CARD EXISTS, COMPUTE LOADS FOR THE
C     ELEMENT. IF NOT, COMPUTE HC CENTROIDAL VALUE ONLY. (ONLYC=.TRUE.)
C     THE PERMBDY SILS START AT Z(ISTART-NBDYS-1)
C
      IF (NBDYS .EQ. 0) GO TO 50
C
      DO 40 I = 1,NGRID
      NG = NECPT(FRSTGD+I-1)
      DO 40 J = 1,NBDYS
      IF (NG .EQ. IZ(ISTART-NBDYS-NELOUT+J-1)) GO TO 50
   40 CONTINUE
C
C     ELEMENT HAS NO GRIDS ON PERMBDY
C
      ONLYC =.TRUE.
      NOPTS = 1
   50 IF (ONLYC .AND. ITYPE.EQ.24) RETURN
C
C     IF ONLYC=TRUE, CHECK TO SEE IF THE ELEMENT HAD AN ELFORCE REQUEST.
C     IF SO, CONTINUE. IF NOT, JUST WRITE ZEROS TO HCCEN,SCR6) AND
C     RETURN.
C
      IF (.NOT.ONLYC) GO TO 70
      IF (ALL .EQ. 1) GO TO 70
      IF (NELOUT .EQ. 0) GO TO 100
C
      DO 60 I = 1,NELOUT
      IF (NECPT(1) .EQ. IZ(ISTART-NELOUT+I-1)) GO TO 70
   60 CONTINUE
      GO TO 100
   70 IF (ITYPE.NE.20 .AND. ITYPE.NE.24) GO TO 130
      G1 = 0.
      G2 = 0.
      G3 = 0.
      H1 = 0.
      H2 = 0.
      H3 = 0.
      DO 80 I = 1,NGRID
      ISUB = ISTART + 3*NECPT(FRSTGD+I-1) - 3
      IF (ITYPE .EQ. 24) ISUB = ISTART + 3*NCOUNT - 3
      H1 = H1 + ABS(Z(ISUB  ))
      H2 = H2 + ABS(Z(ISUB+1))
      H3 = H3 + ABS(Z(ISUB+2))
      G1 = G1 + Z(ISUB  )
      G2 = G2 + Z(ISUB+1)
      G3 = G3 + Z(ISUB+2)
      IF (ITYPE .EQ. 24) GO TO 90
   80 CONTINUE
   90 HL = H1 + H2 + H3
      IF (HL .NE. 0.) GO TO 120
      IF (ITYPE .EQ. 24) RETURN
C
  100 SC(3) = 0.
      SC(4) = 0.
      SC(5) = 0.
      CALL WRITE (SCR6,SC,2,0)
      ISC2  = ISC(2)
      DO 110 I = 1,ISC2
      CALL WRITE (SCR6,SC(3),3,0)
  110 CONTINUE
      RETURN
C
  120 IF (ITYPE .EQ. 24) GO TO 130
C
C     AVERGAGE SPCFLD
C
      AHCX = G1/FLOAT(NGRID)
      AHCY = G2/FLOAT(NGRID)
      AHCZ = G3/FLOAT(NGRID)
C
  130 IF (ELTYPE .GE. 65) GO TO 500
      IF (ONLYC) GO TO 140
C
C     GET MATERIAL INFO
C     INFLAG = 3  RETURNS A 3X3 MATRIX
C
      LL(1,1) = .25
      LL(2,1) = .25
      LL(3,1) = .25
      LL(4,1) = .25
      LL(1,2) = .5
      LL(2,2) = 1./6.
      LL(3,2) = LL(2,2)
      LL(4,2) = LL(2,2)
      LL(1,3) = 1./6.
      LL(2,3) = .5
      LL(3,3) = LL(1,3)
      LL(4,3) = LL(1,3)
      LL(1,4) = 1./6.
      LL(2,4) = LL(1,4)
      LL(3,4) = .5
      LL(4,4) = LL(1,4)
      LL(1,5) = 1./6.
      LL(2,5) = LL(1,5)
      LL(3,5) = LL(1,5)
      LL(4,5) = .5
      W(1)    =-.8
      W(2)    = 9./20.
      W(3)    = W(2)
      W(4)    = W(2)
      W(5)    = W(2)
      INFLAG  = 3
      MATID   = NECPT(MID)
      ELTEMP  = ECPT(ITEMP)
      CALL HMAT (NECPT(1))
C
C     G STORED BY ROW
C
      G(1) = XMAT(1)
      G(2) = XMAT(2)
      G(3) = XMAT(3)
      G(4) = XMAT(2)
      G(5) = XMAT(4)
      G(6) = XMAT(5)
      G(7) = XMAT(3)
      G(8) = XMAT(5)
      G(9) = XMAT(6)
C
C     PUT COORDINATES OF GRID POINTS INTO ARRAY
C     FOR HEXA2  DIVIDE VOLUME BY 2.
C
      XM = 1.
      IF (ELTYPE .EQ. 42) XM = 2.
C
C     TETRA   4 GRID PTS    1 ELEMENT
C     WEDGE   6 GRID PTS   18 ELEMENTS(6 ARE DUPLICATES-4 POINTS AT A
C     HEXA1   8 GRID PTS    5 ELEMENT (4 PTS AT A TIME)
C     HEXA2   8 GRID PTS    10ELEMENT (4 PTS AT A TIME)
C     SET UP PROPER POINTERS VIA TMAP
C     R ARRAY CONTAINS COORDINATE INFO
C
  140 DO 150 I = 1,NGRID
      ITT    = ISYS1 + 4*I - 4
      R(1,I) = ECPT(ITT+1)
      R(2,I) = ECPT(ITT+2)
      R(3,I) = ECPT(ITT+3)
  150 CONTINUE
C
C     SET UP POINTER TO GRID PT NO
C
      IROW = 0
      IF (ELTYPE.EQ.41 .OR. ELTYPE.EQ.42) IROW = 12
      DO 160 I = 1,8
  160 XLOAD(I) = 0.0
C
C     SET UP POINTS FOR AVERAGE COORDINATES
C
      XXC = 0.
      YYC = 0.
      ZZC = 0.
      DO 170 I = 1,NGRID
      XXC = XXC + R(1,I)
      YYC = YYC + R(2,I)
      ZZC = ZZC + R(3,I)
  170 CONTINUE
      XXC = XXC/FLOAT(NGRID)
      YYC = YYC/FLOAT(NGRID)
      ZZC = ZZC/FLOAT(NGRID)
C
C     PRINCIPAL LOOP OVER ELEMENT OF THE GIVEN TYPE
C
      DO 400 IEL = 1,NELS
      IF (ONLYC) GO TO 200
C
C     RESET XM FOR WEDGES. 1ST 12 CONFIGURATIONS ARE MULTIPLIED BY 2.
C     ALL 18 ARE DIVIDED BY 6.(SINCE XM IS A DIVISOR, USE RECIPROCALS)
C
      IF (ELTYPE.EQ.40 .AND. IEL.LE.6) XM = 6./2.
      IF (ELTYPE.EQ.40 .AND. IEL.GT.6) XM = 6.
      ISUB = (IROW+IEL-1)*4
      DO 180 I = 1,4
      F(I)  = 0.
      IP(I) = I
      IF (ELTYPE .GE. 40) IP(I) = TMAP(ISUB+I)
  180 CONTINUE
C
C     NEED DET TO COMPUTE VOL
C
      TERM1 =  R(3,I4)*((R(1,I2)-R(1,I1))*R(2,I3) +
     1        (R(1,I1)-R(1,I3))*R(2,I2) + (R(1,I3)-R(1,I2))*R(2,I1))
      TERM2 =  R(3,I3)*((R(1,I1)-R(1,I2))*R(2,I4) +
     1        (R(1,I4)-R(1,I1))*R(2,I2) + (R(1,I2)-R(1,I4))*R(2,I1))
      TERM3 =  R(3,I2)*((R(1,I3)-R(1,I1))*R(2,I4) + (R(1,I1)-R(1,I4))*
     1         R(2,I3) + (R(1,I4)-R(1,I3))*R(2,I1))
      TERM4 =  R(3,I1)*((R(1,I2)-R(1,I3))*R(2,I4) + (R(1,I4)-R(1,I2))*
     1         R(2,I3) + (R(1,I3)-R(1,I4))*R(2,I2))
      DET   =  TERM1 + TERM2 + TERM3 + TERM4
      VOL   =  ABS(DET)/6.
C
C     GRADIENTS OF SHAPE FUNCTIONS
C
      DR( 1) = R(3,I3)*R(2,I4) - R(3,I4)*R(2,I3) + R(2,I2)*(R(3,I4)-
     1         R(3,I3)) - R(3,I2)*(R(2,I4)-R(2,I3))
      DR( 2) = R(1,I3)*R(3,I4) - R(1,I4)*R(3,I3) - R(1,I2)*(R(3,I4)-
     1         R(3,I3)) + R(3,I2)*(R(1,I4)-R(1,I3))
      DR( 3) = R(2,I3)*R(1,I4) - R(1,I3)*R(2,I4) + R(1,I2)*(R(2,I4)-
     1         R(2,I3)) - R(2,I2)*(R(1,I4)-R(1,I3))
      DR( 4) = R(2,I3)*R(3,I4) - R(2,I4)*R(3,I3) - R(2,I1)*(R(3,I4)-
     1         R(3,I3)) + R(3,I1)*(R(2,I4)-R(2,I3))
      DR( 5) = R(1,I4)*R(3,I3) - R(1,I3)*R(3,I4) + R(1,I1)*(R(3,I4)-
     1         R(3,I3)) - R(3,I1)*(R(1,I4)-R(1,I3))
      DR( 6) = R(1,I3)*R(2,I4) - R(2,I3)*R(1,I4) - R(1,I1)*(R(2,I4)-
     1         R(2,I3)) + R(2,I1)*(R(1,I4)-R(1,I3))
      DR( 7) = R(3,I2)*R(2,I4) - R(2,I2)*R(3,I4) + R(2,I1)*(R(3,I4)-
     1         R(3,I2)) - R(3,I1)*(R(2,I4)-R(2,I2))
      DR( 8) = R(1,I2)*R(3,I4) - R(1,I4)*R(3,I2) - R(1,I1)*(R(3,I4)-
     1         R(3,I2)) + R(3,I1)*(R(1,I4)-R(1,I2))
      DR( 9) = R(2,I2)*R(1,I4) - R(1,I2)*R(2,I4) + R(1,I1)*(R(2,I4)-
     1         R(2,I2)) - R(2,I1)*(R(1,I4)-R(1,I2))
      DR(10) = R(2,I2)*R(3,I3) - R(3,I2)*R(2,I3) - R(2,I1)*(R(3,I3)-
     1         R(3,I2)) + R(3,I1)*(R(2,I3)-R(2,I2))
      DR(11) = R(3,I2)*R(1,I3) - R(1,I2)*R(3,I3) + R(1,I1)*(R(3,I3)-
     1         R(3,I2)) - R(3,I1)*(R(1,I3)-R(1,I2))
      DR(12) = R(1,I2)*R(2,I3) - R(2,I2)*R(1,I3) - R(1,I1)*(R(2,I3)-
     1         R(2,I2)) + R(2,I1)*(R(1,I3)-R(1,I2))
C
      DO 190  K = 1,12
  190 DR(K) = DR(K)/DET
C
C     MULTIPLY SHAPE FUNCTION  BY G
C
      IF (ITYPE .NE. 24) CALL GMMATS (DR(1),4,3,0,G,3,3,0,DR(13))
C
C     COMPUTE HC
C
      IF (ITYPE .NE. 24) GO TO 200
C
C     REMFLUX
C
      NSUBX = ISTART + 3*NCOUNT - 3
      HC(1) = Z(NSUBX)
      HC(2) = Z(NSUBX+1)
      HC(3) = Z(NSUBX+2)
      GO TO 360
C
C     INTEGRATE TO GET HC
C
  200 KTYPE = ITYPE - 19
      XLACC(1) = 0.
      XLACC(2) = 0.
      XLACC(3) = 0.
C
C     START INTEGRATION PROCEDURE-NEED 5 POINTS FOR CUBIC + CENTROID
C
      DO 340 NPTS = 1,NOPTS
C
C     DO CENTROID FOR ONLY 1ST TETRA
C
      IF (NPTS.EQ.NOPTS .AND. IEL.GT.1) GO TO 340
C
C     COMPUTE BASIC COORDS OF INTEGRATION POINT
C
      IF (NPTS .NE. NOPTS) GO TO 210
C
C     CENTROID
C
      XX = XXC
      YY = YYC
      ZZ = ZZC
      IF (ITYPE .NE. 20) GO TO 220
C
C     AVERAGE SPCFLD
C
      HC(1) = AHCX
      HC(2) = AHCY
      HC(3) = AHCZ
      GO TO 310
  210 XX = LL(1,NPTS)*R(1,I1) + LL(2,NPTS)*R(1,I2) + LL(3,NPTS)*R(1,I3)
     1   + LL(4,NPTS)*R(1,I4)
      YY = LL(1,NPTS)*R(2,I1) + LL(2,NPTS)*R(2,I2) + LL(3,NPTS)*R(2,I3)
     1   + LL(4,NPTS)*R(2,I4)
      ZZ = LL(1,NPTS)*R(3,I1) + LL(2,NPTS)*R(3,I2) + LL(3,NPTS)*R(3,I3)
     1   + LL(4,NPTS)*R(3,I4)
  220 HC(1) = 0.
      HC(2) = 0.
      HC(3) = 0.
C
C     COMPUTE HC AT THIS PPOINT FOR ALL LOADS OF THIS TYPE IN THIS
C     SUBCASE
C
      DO 300 IJK = 1,IDO
      IF (ITYPE .EQ. 20) GO TO 240
      ISUB = ISTART + (IJK-1)*IWORDS - 1
      DO 230 I = 1,IWORDS
  230 BUF(I) = Z(ISUB+I)
C
      GO TO (240,260,270,280), KTYPE
C
C     SPCFLD
C
  240 DO 250 I = 1,4
      ISIL = FRSTGD - 1 + IP(I)
      IST  = ISTART + 3*NECPT(ISIL) - 3
      HCX(I) = Z(IST  )
      HCY(I) = Z(IST+1)
      HCZ(I) = Z(IST+2)
  250 CONTINUE
      HC1 = LL(1,NPTS)*HCX(1) + LL(2,NPTS)*HCX(2) + LL(3,NPTS)*HCX(3) +
     1      LL(4,NPTS)*HCX(4)
      HC2 = LL(1,NPTS)*HCY(1) + LL(2,NPTS)*HCY(2) + LL(3,NPTS)*HCY(3) +
     1      LL(4,NPTS)*HCY(4)
      HC3 = LL(1,NPTS)*HCZ(1) + LL(2,NPTS)*HCZ(2) + LL(3,NPTS)*HCZ(3) +
     1      LL(4,NPTS)*HCZ(4)
      GO TO 290
C
C     CEMLOOP,GEMLOOP,MDIPOLE
C
  260 CALL AXLOOP (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
      GO TO 290
  270 CALL GELOOP (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
      GO TO 290
  280 CALL DIPOLE (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
  290 HC(1) = HC(1) + HC1
      HC(2) = HC(2) + HC2
      HC(3) = HC(3) + HC3
  300 CONTINUE
  310 IF (NPTS .NE. NOPTS) GO TO 320
      SC(3) = HC(1)
      SC(4) = HC(2)
      SC(5) = HC(3)
      CALL WRITE (SCR6,SC,5,0)
      GO TO 340
C
C     WE HAVE HC AT THIS POINT. MULT. BY  WEIGHT AND ACCUMULATE
C
  320 DO 330 I = 1,3
  330 XLACC(I) = XLACC(I) + HC(I)*W(NPTS)
C
C     GET ANOTHER INTEGRATTION POINT
C
  340 CONTINUE
C
      IF (ONLYC) RETURN
      DO 350 I = 1,3
  350 HC(I) = XLACC(I)
  360 CONTINUE
C
C     MULTIPLY HC BY GRADIENTS AND MATERIALS
C
      ISUBX = 13
      IF (ITYPE .EQ. 24) ISUBX = 1
      CALL GMMATS (DR(ISUBX),4,3,0,HC,3,1,0,F(1))
C
      DO 370 K = 1,4
      KK = IP(K)
  370 XLOAD(KK) = XLOAD(KK) + F(K)*VOL/XM
C
C     XLOAD   IS SUM OF ALL LOADS FOR ALL THE ELEMENTS
C     F COMPUTED FOR A GIVEN TETRA OF THE TOTAL SHAPE
C     SO MULTIPLY BY VOL
C
  400  CONTINUE
C
      DO 430  I = 1,NGRID
      IS   = FRSTGD - 1 + I
      ISIL = NECPT(IS)
C
C     IF PERMBDY EXISTS AND IF GRID IS NOT ON IT, IGNORE ITS LOAD
C
      IF (NBDYS .EQ. 0) GO TO 420
      DO 410 J = 1,NBDYS
      IF (ISIL .NE. IZ(ISTART-NBDYS-NELOUT+J-1)) GO TO 410
      GO TO 420
  410 CONTINUE
      GO TO 430
  420 Z(ISIL) = Z(ISIL) - XLOAD(I)
  430 CONTINUE
      RETURN
C
C     ISOPARAMETRIC SOLIDS
C
  500 JTYPE = ITYPE
      ITYPE = ELTYPE - 64
      INIP  = NECPT(NIP)
      IF (INIP .EQ. 0) INIP = ITYPE/2 + 2
      NP    = 12*ITYPE - 4
      ELID  = NECPT(1)
C
C     SET UP FOR FETCHING SHAPE FUNCTIONS
C
      DO 510 I = 1,NP
      GPT(I) = ECPT(ITEMP-1+I)
      DO 510 J = 1,3
      BXYZ(J,I) = ECPT(NP+4+4*I+J)
  510 CONTINUE
      IF (ONLYC) GO TO 570
      I = INIP - 1
      GO TO (520,530,540), I
  520 H(1)  = 1.
      S(1)  = GAUSS(1)
      H(2 ) = H(1)
      S(2)  = -S(1)
      GO TO 550
  530 H(1)  = GAUSS(2)
      S(1)  = GAUSS(3)
      H(2 ) = GAUSS(4)
      S(2)  = 0.
      H(3 ) = H(1)
      S(3 ) = -S(1)
      GO TO 550
  540 H(1 ) = GAUSS(5)
      S(1)  = GAUSS(6)
      H(2)  = GAUSS(7)
      S(2)  = GAUSS(8)
      H(3)  = H(2)
      S(3)  = -S(2)
      H(4) = H(1)
      S(4) = -S(1)
  550 DO 560 I = 1,32
  560 F(I) = 0.0
C
C     SET UP HC ARRAY GIVING HC AT EACH GRID
C
      IF (JTYPE .NE. 24) GO TO 570
C
C     REMFLUX
C
      ISUB  = ISTART + 3*NCOUNT - 3
      GH(1) = Z(ISUB)
      GH(2) = Z(ISUB+1)
      GH(3) = Z(ISUB+2)
      GO TO 610
C
C     IF SPCFLD,PICK UP GRID VALUES HERE. IF NOT, PICK UP INTEGRATION
C     POINT VALUES LATER.(THERE IS ONLY ONE SPCFLD CARD AT THIS POINT)
C
  570 IF (JTYPE .NE. 20) GO TO 590
      DO 580 I = 1,NP
      ISIL = 3*NECPT(I+1)
      HC(3*I-2) = Z(ISTART+ISIL-3)
      HC(3*I-1) = Z(ISTART+ISIL-2)
      HC(3*I  ) = Z(ISTART+ISIL-1)
  580 CONTINUE
  590 INFLAG = 3
      MATID  = NECPT(MID)
  610 KTYPE  = JTYPE - 20
      IF (ONLYC) GO TO 850
C
C     START INTEGRATION
C
      DO 800 I = 1,INIP
      DO 800 J = 1,INIP
      DO 800 K = 1,INIP
C
C     FETCH SHAPE FUNCTIONS FOR THIS INTEGRATION POINT
C
      CALL IHEXSS(ITYPE,SHP,DSHP,XJACOB,DETJ,ELID,S(I),S(J),S(K),BXYZ)
C
C     COMPUTE NI W.R.T. X,Y,Z(REVERVSE CALLING SEQUENCE,SINCE COL STOR)
C
      CALL GMMATS(DSHP,NP,3,0,XJACOB,3,3,0,DSHPB)
C
C     COMPUTE TEMPERATURES AND HC  AT THIS INTEGRSTION POINT
C
      ELTEMP = 0
      DO 620 L = 1,NP
      ELTEMP = ELTEMP + SHP(L)*GPT(L)
  620 CONTINUE
      IF (JTYPE .EQ. 24) GO TO 730
      HCXYZ(1) = 0.
      HCXYZ(2) = 0.
      HCXYZ(3) = 0.
      IF (JTYPE .EQ. 20) GO TO 700
C
C     FOR LOOPS AND DIPOLES, COMPUTE BASIC COORDS FOR THIS INTEGRATION
C     POINT
C
      XX = 0.
      YY = 0.
      ZZ = 0.
      DO 630 L = 1,NP
      XX = XX + SHP(L)*BXYZ(1,L)
      YY = YY + SHP(L)*BXYZ(2,L)
      ZZ = ZZ + SHP(L)*BXYZ(3,L)
  630 CONTINUE
      DO 690 IJK = 1,IDO
      ISUB = ISTART + (IJK-1)*IWORDS - 1
      DO 640 L = 1,IWORDS
  640 BUF(L) = Z(ISUB+L)
C
C     COMPUTE HC AT THIS POINT DUE TO ALL LOADS OF PRESENT TYPE
C
      GO TO (650,660,670), KTYPE
  650 CALL AXLOOP (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
      GO TO 680
  660 CALL GELOOP (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
      GO TO 680
  670 CALL DIPOLE (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
  680 HCXYZ(1) = HCXYZ(1) + HC1
      HCXYZ(2) = HCXYZ(2) + HC2
      HCXYZ(3) = HCXYZ(3) + HC3
  690 CONTINUE
      GO TO 720
C
C     SPCFLD
C
  700 DO 710  L = 1,NP
      HCXYZ(1) = HCXYZ(1) + SHP(L)*HC(3*L-2)
      HCXYZ(2) = HCXYZ(2) + SHP(L)*HC(3*L-1)
      HCXYZ(3) = HCXYZ(3) + SHP(L)*HC(3*L  )
  710 CONTINUE
C
      CALL HMAT(ELID)
C
  720 G(1) = XMAT(1)
      G(2) = XMAT(2)
      G(3) = XMAT(3)
      G(4) = XMAT(2)
      G(5) = XMAT(4)
      G(6) = XMAT(5)
      G(7) = XMAT(3)
      G(8) = XMAT(5)
      G(9) = XMAT(6)
C
      CALL GMMATS (G,3,3,0,HCXYZ,3,1,0,GH)
C
  730 SFACT = H(I)*H(J)*H(K)*DETJ
      DO 740 L = 1,NP
      F(L) = F(L) + (DSHPB(1,L)*GH(1) + DSHPB(2,L)*GH(2) +
     1       DSHPB(3,L)*GH(3))*SFACT
  740 CONTINUE
C
C     GET ANOTHER INTEGRATIONPOINT
C
  800 CONTINUE
C
C     ADD LOADS INTO LOAD ARRAY
C
      DO 840 L = 1,NP
      ISIL = NECPT(FRSTGD+L-1)
C
C     IF PERMBDY EXISTS AND IF GRID IS NOT ON IT, IGNORE ITS LOAD
C
      IF (NBDYS .EQ. 0) GO TO 830
      DO 820 I = 1,NBDYS
      IF (ISIL .NE. IZ(ISTART-NBDYS-NELOUT+I-1)) GO TO 820
      GO TO 830
  820 CONTINUE
      GO TO 840
  830 Z(ISIL) = Z(ISIL) - F(L)
  840 CONTINUE
  850 ITYPE = JTYPE
C
C     BEFORE LEAVING, WE MUST COMPUTE HC VALUES AT GRIDS OF ISOPARA-
C     METRICS AND WRITE TO SCR6
C
      IF (JTYPE .EQ. 24) GO TO 1150
      CALL WRITE (SCR6,ISC,2,0)
      IF (JTYPE .NE. 20) GO TO 1010
C
C     FOR SPCFLD THE VALUES ARE IN CORE(EXCEPT FOR MIFPOINTS OF IHEX3)
C
      IF (ELTYPE .EQ. 67) GO TO 880
      CALL WRITE (SCR6,HC,3*NP,0)
C
C     CENTROID/ XI = ETA = ZETA = 0
C
  860 CALL IHEXSS (ELTYPE-64,SHP,DSHP,XJACOB,DETJ,ELID,0.,0.,0.,BXYZ)
      HCX3(1) = 0.
      HCX3(2) = 0.
      HCX3(3) = 0.
      DO 870 L = 1,NP
      HCX3(1) = HCX3(1) + SHP(L)*HC(3*L-2)
      HCX3(2) = HCX3(2) + SHP(L)*HC(3*L-1)
      HCX3(3) = HCX3(3) + SHP(L)*HC(3*L  )
  870 CONTINUE
      CALL WRITE (SCR6,HCX3,3,0)
      GO TO 1150
  880 ISUB1 = 1
      ISUB2 = 10
      J = -5
  890 DO 900 I = ISUB1,ISUB2,3
      J = J + 6
      K = 3*I - 2
      HCX3(J  ) = HC(K  )
      HCX3(J+1) = HC(K+1)
      HCX3(J+2) = HC(K+2)
      HCX3(J+3) = .5*(HC(K+3) + HC(K+6))
      HCX3(J+4) = .5*(HC(K+4) + HC(K+7))
      HCX3(J+5) = .5*(HC(K+5) + HC(K+8))
  900 CONTINUE
      IF (ISUB1 .EQ. 21) GO TO 1000
      J = 22
      DO 910 I = 13,16
      J = J + 3
      K = 3*I - 2
      HCX3(J  ) = .5*(HC(K  ) + HC(K+12))
      HCX3(J+1) = .5*(HC(K+1) + HC(K+13))
      HCX3(J+2) = .5*(HC(K+2) + HC(K+14))
  910 CONTINUE
      ISUB1 = 21
      ISUB2 = 30
      J = 31
      GO TO 890
C
C     DONE - WRITE RESULTS
C
 1000 CALL WRITE (SCR6,HCX3,60,0)
      GO TO 860
C
C     CEMLOOP, GEMLOOP, MDIPOLE
C
 1010 NX = NP + 1
      IF (ELTYPE .EQ. 67) NX = 21
      DO 1140 J = 1,NX
      IF (J .NE. NX) GO TO 1030
C
C     CENTROID
C
      CALL IHEXSS (ELTYPE-64,SHP,DSHP,XJACOB,DETJ,ELID,0.,0.,0.,BXYZ)
      XX = 0.
      YY = 0.
      ZZ = 0.
      DO 1020 L = 1,NP
      XX = XX + SHP(L)*BXYZ(1,L)
      YY = YY + SHP(L)*BXYZ(2,L)
      ZZ = ZZ + SHP(L)*BXYZ(3,L)
 1020 CONTINUE
      GO TO 1070
C
 1030 IF (ELTYPE .NE. 67) GO TO 1060
C
C     IHEX3
C
      IF (J.EQ. 1) K1 =-1
      IF (J.EQ.13) K1 = 7
      IF (J.EQ. 1) K2 =-1
      IF (J.EQ.13) K2 = 7
      IF (J.LT.9 .OR. J.GT.12) GO TO 1040
      XX = .5*(BXYZ(1,J+4) + BXYZ(1,J+8))
      YY = .5*(BXYZ(2,J+4) + BXYZ(2,J+8))
      ZZ = .5*(BXYZ(3,J+4) + BXYZ(3,J+8))
      GO TO 1070
 1040 IF ((J/2)*2 .NE. J)GO TO 1050
      K1 = K1 + 1
      XX = .5*(BXYZ(1,J+K1) + BXYZ(1,J+K1+1))
      YY = .5*(BXYZ(2,J+K1) + BXYZ(2,J+K1+1))
      ZZ = .5*(BXYZ(3,J+K1) + BXYZ(3,J+K1+1))
      GO TO 1070
 1050 K2 = K2 + 1
      XX = BXYZ(1,J+K2)
      YY = BXYZ(2,J+K2)
      ZZ = BXYZ(3,J+K2)
      GO TO 1070
C
 1060 XX = BXYZ(1,J)
      YY = BXYZ(2,J)
      ZZ = BXYZ(3,J)
 1070 HC(1) = 0.
      HC(2) = 0.
      HC(3) = 0.
      DO 1130 IJK = 1,IDO
      ISUB = ISTART + (IJK-1)*IWORDS - 1
      DO 1080 I = 1,IWORDS
 1080 BUF(I) = Z(ISUB+I)
C
C     COMPUTE HC AT THIS POINT
C
      GO TO (1090,1100,1110), KTYPE
 1090 CALL AXLOOP (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
      GO TO 1120
 1100 CALL GELOOP (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
      GO TO 1120
 1110 CALL DIPOLE (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
 1120 HC(1) = HC(1) + HC1
      HC(2) = HC(2) + HC2
      HC(3) = HC(3) + HC3
 1130 CONTINUE
C
      CALL WRITE (SCR6,HC,3,0)
 1140 CONTINUE
C
 1150 RETURN
C
 1200 WRITE  (OUTPT,1210) UFM
 1210 FORMAT (A23,' - WRONG ELEMENT TYPE IN EM3D PROBLEM.')
      CALL MESAGE (-61,0,0)
      RETURN
      END


	SUBROUTINE BFRCHK ( lunin, catprm, ncats, ncatvl, catvls, msgok,
     +			    lvlflg, iret )
C************************************************************************
C* BFRCHK								*
C*									*
C* This subroutine reads the values of the screening parameters from	*
C* a Woollen BUFR file and sets logical flag for acceptance.		*
C*									*
C*									*
C*									*
C* BFRCHK ( LUNIN, CATPRM, NCATS, NCATVL, CATVLS, MSGOK, LVLFLG, IRET ) *
C*									*
C* Input parameters:							*
C*	LUNIN		INTEGER		BUFR file unit number		*
C*	CATPRM		CHAR*		Blank-separated mnemonic list	*
C*	NCATS		INTEGER		Number in the list		*
C*	NCATVL (NCATS)	INTEGER		# of values for each mnemonic	*
C*	CATVLS (*)	REAL		Values				*
C*									*
C* Output parameters:							*
C*	MSGOK		LOGICAL		Flag to accept message		*
C*	LVLFLG (*)	LOGICAL		Flag to accept levels		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C*					-38 = not all chk parms found	*
C**									*
C* Log:									*
C* K. Brill/EMC		 7/98						*
C* K. Brill/HPC		 3/01	Return LVLFLG; error -39		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	PARAMETER	( MXDAT = 2000 )
C*
	CHARACTER*(*)	catprm
	INTEGER		ncatvl (*)
	REAL		catvls (*)
	LOGICAL		lvlflg (*), msgok
C*
	REAL*8		fbufr (MXDAT)
	LOGICAL		ok, found
	INCLUDE		'ERMISS.FNC'
C----------------------------------------------------------------------
	iret = 0
	msgok = .true.
	IF ( ncats .eq. 0 ) RETURN
C*
	CALL ST_LSTR ( catprm, lng, ier )
	CALL JB_READ ( lunin, catprm(1:lng), MXDAT, fbufr, np, nlv,
     +			ier )
	IF ( ier .ne. 0 .or. np .ne. ncats ) THEN
	    iret = -38
	    RETURN
	END IF
	IF ( nlv .gt. LLMXLV ) THEN
	    iret = -39
	    RETURN
	END IF
C*
	msgok = .false.
	indx = 0
	DO k = 1, nlv
	    ok = .true.
	    DO i = 1, np
		indx = indx + 1
C
C*		Isolate CATVLS values to compare.
C
		IF ( i .ne. 1 ) THEN
		    istrt = 0
		    DO jp = 1, i-1
			istrt = istrt + ncatvl (jp)
		    END DO
		    istop = istrt + ncatvl (i)
		    istrt = istrt + 1
		ELSE
		    istrt = 1
		    istop = ncatvl (1)
		END IF
		found = .false.
		ii = istrt
		DO WHILE (  .not. found .and. ii .le. istop )
		    found = ( ABS ( fbufr (indx) - catvls (ii) ) .lt.
     +			     .0005 )
		    ii = ii + 1
		END DO
		ok = ok .and. found
	    END DO
	    lvlflg (k) = ok
	    msgok = ok .or. msgok
	END DO
C*
	RETURN
	END


c $Id: options.f,v 1.1 2012/11/29 21:00:08 jwebb Exp $
c... law: include file (only) for global parameters & options
      integer numcto,numctp,maxstables
      parameter(numcto=400) ! maximum number of options
      parameter(numctp=400) ! maximum number of parameters
      parameter(maxstables=20) ! maximum number of stable particles
c...
      integer   CTOption(numcto)
      character ctodc(numcto)*2
c...
      real*8    CTParam(numctp)
      character ctpdc(numctp)*2

      integer nstable
      integer stabvec(maxstables)

      logical bf13,bf14,bf15,bf16,bf17,bf18,bf19,bf20,fixedseed
      common /options/CTOption,CTParam
      common /optstrings/ctodc,ctpdc
      common /loptions/fixedseed,bf13,bf14,bf15,bf16,bf17,bf18,
     .     bf19,bf20
      common /stables/nstable,stabvec


!> \file moninshoc.f
!!  Contains most of the SHOC PBL/shallow convection scheme.

!> This module contains the CCPP-compliant SHOC scheme.
      module moninshoc

      contains

      subroutine moninshoc_init (do_shoc, errmsg, errflg)

      implicit none
      logical, intent(in) :: do_shoc
      character(len=*), intent(out) :: errmsg
      integer,          intent(out) :: errflg

      ! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0

      ! Consistency checks
      if (.not. do_shoc) then
        errflg = 1
        write(errmsg,'(*(a))') 'Logic error: do_shoc = .false.'
       return
      end if

      end subroutine moninshoc_init

      subroutine moninshoc_finalize ()
      end subroutine moninshoc_finalize

!!!!!  ==========================================================  !!!!!
! subroutine 'moninshoc' computes pbl height and applies vertical diffusion
! using the coefficient provided by the SHOC scheme (from previous step)
! 2015-05-04 - Shrinivas Moorthi - original version based on monin
! 2018-03-21 - Shrinivas Moorthi - fixed a bug related to tke vertical diffusion
!                                  and gneralized the tke location in tracer array
! 2018-03-23 - Shrinivas Moorthi - used twice the momentum diffusion coefficient
!                                  for tke as in Deardorff (1980) - added tridi1
!
!> \section arg_table_moninshoc_run Argument Table
!! \htmlinclude moninshoc_run.html
!!
      subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg,
     &                          u1,v1,t1,q1,tkh,prnum,ntke,
     &                          psk,rbsoil,zorl,u10m,v10m,fm,fh,
     &                          tsea,heat,evap,stress,spd1,kpbl,
     &                          prsi,del,prsl,prslk,phii,phil,delt,
     &                          dusfc,dvsfc,dtsfc,dqsfc,dkt,hpbl,
     &                          kinver,xkzm_m,xkzm_h,xkzm_s,xkzminv,
     &                          grav,rd,cp,hvap,fv,ntoz,dtend,dtidx,
     &                          index_of_temperature,index_of_x_wind,
     &                          index_of_y_wind,index_of_process_pbl,
     &                          gen_tend,ldiag3d,ntqv,errmsg,errflg)
!
      use machine  , only : kind_phys
      use funcphys , only : fpvs

      implicit none
!
!     arguments
!
      integer,                                  intent(in) :: im,
     &  km, ntrac, ntcw, ncnd, ntke, ntoz
      integer, dimension(:),                   intent(in) ::  kinver
      real(kind=kind_phys),                     intent(in) :: delt,
     &  xkzm_m, xkzm_h, xkzm_s, xkzminv
      real(kind=kind_phys),                     intent(in) :: grav,
     &  rd, cp, hvap, fv
      real(kind=kind_phys), dimension(:),      intent(in) :: psk,
     &  rbsoil, zorl, u10m, v10m, fm, fh, tsea, heat, evap, stress, spd1
      real(kind=kind_phys), dimension(:,:),   intent(in) :: u1, v1,
     &  t1, tkh, del, prsl, phil, prslk
      real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii
      real(kind=kind_phys), dimension(:,:,:), intent(in) :: q1

      real(kind=kind_phys), dimension(:,:),   intent(inout) :: du, dv,
     &  tau
      real(kind=kind_phys), dimension(:,:,:), intent(inout) :: rtg

      real(kind=kind_phys), dimension(:,:,:),   intent(inout) :: dtend
      integer,              dimension(:,:),     intent(in)    :: dtidx
      integer, intent(in) :: index_of_temperature, index_of_x_wind,
     &  index_of_y_wind, index_of_process_pbl, ntqv
      logical,                                  intent(in) :: ldiag3d,
     &  gen_tend

      integer, dimension(:),                    intent(out) :: kpbl
      real(kind=kind_phys), dimension(:),       intent(out) :: dusfc,
     &  dvsfc, dtsfc, dqsfc, hpbl
      real(kind=kind_phys), dimension(:,:),     intent(out) :: prnum
      real(kind=kind_phys), dimension(:,:),     intent(out) :: dkt

      character(len=*),                         intent(out) :: errmsg
      integer,                                  intent(out) :: errflg
!
!    locals
!
      integer, parameter :: kp = kind_phys
      integer i,is,k,kk,km1,kmpbl,kp1, ntloc
!
      logical  pblflg(im), sfcflg(im), flg(im)

      real(kind=kind_phys), dimension(im) ::  phih, phim
     &,                     rbdn, rbup, sflux, z0, crb, zol, thermal
     &,                     beta, tx1
!
      real(kind=kind_phys), dimension(im,km)  :: theta, thvx, zl, a1, ad
     &,                                          dt2odel
      real(kind=kind_phys), dimension(im,km-1):: xkzo, xkzmo, al, au
     &,                                          dku, rdzt
!
      real(kind=kind_phys) zi(im,km+1), a2(im,km*(ntrac+1))
!
      real(kind=kind_phys) dsdz2,  dsdzq,  dsdzt, dsig, dt2, rdt
     &,                    dtodsd, dtodsu, rdz,   tem,  tem1
     &,                    ttend,  utend, vtend,  qtend
     &,                    spdk2,  rbint, ri,     zol1, robn, bvf2
!
      real(kind=kind_phys), parameter ::  one=1.0_kp, zero=0.0_kp
     &,              zolcr=0.2_kp,
     &               zolcru=-0.5_kp, rimin=-100.0_kp, sfcfrac=0.1_kp,
     &               crbcon=0.25_kp, crbmin=0.15_kp,  crbmax=0.35_kp,
     &               qmin=1.0e-8_kp, zfmin=1.0d-8,    qlmin=1.0e-12_kp,
     &               aphi5=5.0_kp,   aphi16=16.0_kp,  f0=1.0e-4_kp
     &,              dkmin=zero,     dkmax=1000.0_kp
!    &,              dkmin=zero,     dkmax=1000.,     xkzminv=0.3
     &,              prmin=0.25_kp,  prmax=4.0_kp,    vk=0.4_kp,
     &               cfac=6.5_kp
      real(kind=kind_phys) :: gravi, cont, conq, gocp, go2
      integer :: idtend

      gravi = one  / grav
      cont  = cp   * gravi
      conq  = hvap * gravi
      gocp  = grav / cp
      go2   = grav * 0.5_kp

! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0
!
! Set intent(out) variables
      dkt = zero
!
!-----------------------------------------------------------------------
!
!     compute preliminary variables
!
      dt2   = delt
      rdt   = one / dt2
      km1   = km - 1
      kmpbl = km / 2
!
      rtg = zero
!
      do k=1,km
        do i=1,im
          zi(i,k)      = phii(i,k) * gravi
          zl(i,k)      = phil(i,k) * gravi
          dt2odel(i,k) = dt2 / del(i,k)
        enddo
      enddo
      do i=1,im
         zi(i,km+1) = phii(i,km+1) * gravi
      enddo
!
      do k = 1,km1
        do i=1,im
          rdzt(i,k)  = one / (zl(i,k+1) - zl(i,k))
          prnum(i,k) = one
        enddo
      enddo
!               Setup backgrond diffision
      do i=1,im
        prnum(i,km) = one
        tx1(i) = one / prsi(i,1)
      enddo
      do k = 1,km1
        do i=1,im
          xkzo(i,k)  = zero
          xkzmo(i,k) = zero
!         if (k < kinver(i)) then
          if (k <= kinver(i)) then
!    vertical background diffusivity for heat and momentum
            tem1       = one - prsi(i,k+1) * tx1(i)
            tem1       = min(one, exp(-tem1 * tem1 * 10.0_kp))
            xkzo(i,k)  = xkzm_h * tem1
            xkzmo(i,k) = xkzm_m * tem1
          endif
        enddo
      enddo
!
!  diffusivity in the inversion layer is set to be xkzminv (m^2/s)
!
      do k = 1,kmpbl
        do i=1,im
          if(zi(i,k+1) > 250.0_kp) then
            tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k)
            if(tem1 > 1.0e-5_kp) then
               xkzo(i,k)  = min(xkzo(i,k),xkzminv)
            endif
          endif
        enddo
      enddo
!
!
      do i = 1,im
         z0(i)     = 0.01_kp * zorl(i)
         kpbl(i)   = 1
         hpbl(i)   = zi(i,1)
         pblflg(i) = .true.
         sfcflg(i) = .true.
         if(rbsoil(i) > zero) sfcflg(i) = .false.
         dusfc(i)  = zero
         dvsfc(i)  = zero
         dtsfc(i)  = zero
         dqsfc(i)  = zero
      enddo
!
      do k = 1,km
        do i=1,im
          tx1(i) = zero
        enddo
        do kk=1,ncnd
          do i=1,im
            tx1(i) = tx1(i) + max(q1(i,k,ntcw+kk-1), qlmin)
          enddo
        enddo
        do i = 1,im
          theta(i,k) = t1(i,k) * psk(i) / prslk(i,k)
          thvx(i,k)  = theta(i,k)*(one+fv*max(q1(i,k,1),qmin)-tx1(i))
        enddo
      enddo
!
      do i = 1,im
         sflux(i)  = heat(i) + evap(i)*fv*theta(i,1)
         if (.not.sfcflg(i) .or. sflux(i) <= zero) pblflg(i)=.false.
         beta(i)  = dt2 / (zi(i,2)-zi(i,1))
      enddo
!
!  compute the pbl height
!
!     write(0,*)' IN moninbl u10=',u10m(1:5),' v10=',v10m(1:5)
      do i=1,im
         flg(i)  = .false.
         rbup(i) = rbsoil(i)
!
         if (pblflg(i)) then
           thermal(i) = thvx(i,1)
           crb(i) = crbcon
         else
           thermal(i) = tsea(i)*(one+fv*max(q1(i,1,1),qmin))
           tem   = max(one, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)))
           robn   = tem / (f0 * z0(i))
           tem1   = 1.0e-7_kp * robn
           crb(i) = max(min(0.16_kp * (tem1 ** (-0.18_kp)), crbmax),
     &                                                      crbmin)
         endif
      enddo
      do k = 1, kmpbl
        do i = 1, im
          if (.not.flg(i)) then
            rbdn(i) = rbup(i)
            spdk2   = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), one)
            rbup(i) = (thvx(i,k)-thermal(i))*phil(i,k)
     &              / (thvx(i,1)*spdk2)
            kpbl(i) = k
            flg(i)  = rbup(i) > crb(i)
          endif
        enddo
      enddo
      do i = 1,im
        if(kpbl(i) > 1) then
          k = kpbl(i)
          if (rbdn(i) >= crb(i)) then
            rbint = zero
          elseif(rbup(i) <= crb(i)) then
            rbint = one
          else
            rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i))
          endif
          hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
          if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
        else
          hpbl(i) = zl(i,1)
          kpbl(i) = 1
        endif
      enddo
!
!  compute similarity parameters
!
      do i=1,im
         zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin)
         if (sfcflg(i)) then
           zol(i) = min(zol(i),-zfmin)
         else
           zol(i) = max(zol(i),zfmin)
         endif
         zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1)
         if (sfcflg(i)) then
!          phim(i) = (1.-aphi16*zol1)**(-1./4.)
!          phih(i) = (1.-aphi16*zol1)**(-1./2.)
           tem     = one / max(one - aphi16*zol1, 1.0e-8_kp)
           phih(i) = sqrt(tem)
           phim(i) = sqrt(phih(i))
         else
           phim(i) = one + aphi5*zol1
           phih(i) = phim(i)
         endif
      enddo
!
!  enhance the pbl height by considering the thermal excess
!
      do i=1,im
         flg(i)  = .true.
         if (pblflg(i)) then
           flg(i) = .false.
           rbup(i) = rbsoil(i)
         endif
      enddo
      do k = 2, kmpbl
        do i = 1, im
          if (.not.flg(i)) then
            rbdn(i) = rbup(i)
            spdk2   = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), one)
            rbup(i) = (thvx(i,k)-thermal(i)) * phil(i,k)
     &              / (thvx(i,1)*spdk2)
            kpbl(i) = k
            flg(i)  = rbup(i) > crb(i)
          endif
        enddo
      enddo
      do i = 1,im
        if (pblflg(i)) then
          k = kpbl(i)
          if(rbdn(i) >= crb(i)) then
            rbint = zero
          elseif(rbup(i) <= crb(i)) then
            rbint = one
          else
            rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i))
          endif
          if (k > 1) then
            hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
            if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
            if(kpbl(i) <= 1) then
              pblflg(i) = .false.
            endif
          else
            pblflg(i) = .false.
          endif
        endif
        if (pblflg(i)) then
          tem = phih(i)/phim(i) + cfac*vk*sfcfrac
        else
          tem = phih(i)/phim(i)
        endif
        prnum(i,1) = min(prmin,max(prmax,tem))
      enddo
!
      do i = 1, im
        if(zol(i) > zolcr) then
          kpbl(i) = 1
        endif
      enddo
!
!  compute Prandtl number above boundary layer
!
      do k = 1, km1
        kp1 = k + 1
        do i=1,im
          if(k >= kpbl(i)) then
            rdz  = rdzt(i,k)
            tem  = u1(i,k) - u1(i,kp1)
            tem1 = v1(i,k) - v1(i,kp1)
            tem  = (tem*tem + tem1*tem1) * rdz * rdz
            bvf2 = go2*(thvx(i,kp1)-thvx(i,k))*rdz / (t1(i,k)+t1(i,kp1))
            ri   = max(bvf2/tem,rimin)
            if(ri < zero) then ! unstable regime
              prnum(i,kp1) = one
            else
              prnum(i,kp1) = min(one + 2.1_kp*ri, prmax)
            endif
          elseif (k > 1) then
            prnum(i,kp1) = prnum(i,1)
          endif
!
!         prnum(i,kp1) = one
          prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1)))
          tem      = tkh(i,kp1) * prnum(i,kp1)
          dku(i,k) = max(min(tem+xkzmo(i,k),       dkmax), xkzmo(i,k))
          dkt(i,k) = max(min(tkh(i,kp1)+xkzo(i,k), dkmax), xkzo(i,k))
        enddo
      enddo
!
!     compute tridiagonal matrix elements for heat and moisture
!
      do i=1,im
         ad(i,1) = one
         a1(i,1) = t1(i,1)   + beta(i) * heat(i)
         a2(i,1) = q1(i,1,1) + beta(i) * evap(i)
      enddo

      ntloc = 1
      if(ntrac > 1) then
        is    = 0
        do k = 2, ntrac
          if (k /= ntke) then
            ntloc = ntloc + 1
            is = is + km
            do i = 1, im
              a2(i,1+is) = q1(i,1,k)
            enddo
          endif
        enddo
      endif
!
      do k = 1,km1
        kp1 = k + 1
        do i = 1,im
          dtodsd    = dt2odel(i,k)
          dtodsu    = dt2odel(i,kp1)
          dsig      = prsl(i,k)-prsl(i,kp1)
          rdz       = rdzt(i,k)
          tem1      = dsig * dkt(i,k) * rdz
          dsdz2     = tem1 * rdz
          au(i,k)   = -dtodsd*dsdz2
          al(i,k)   = -dtodsu*dsdz2
!
          ad(i,k)   = ad(i,k)-au(i,k)
          ad(i,kp1) = one - al(i,k)
          dsdzt     = tem1 * gocp
          a1(i,k)   = a1(i,k)   + dtodsd*dsdzt
          a1(i,kp1) = t1(i,kp1) - dtodsu*dsdzt
          a2(i,kp1) = q1(i,kp1,1)
!
        enddo
      enddo
!
      if(ntrac > 1) then
        is = 0
        do kk = 2, ntrac
          if (kk /= ntke) then
            is = is + km
            do k = 1, km1
              kp1 = k + 1
              do i = 1, im
                a2(i,kp1+is) = q1(i,kp1,kk)
              enddo
            enddo
          endif
        enddo
      endif
!
!     solve tridiagonal problem for heat, moisture and tracers
!
      call tridin(im,km,ntloc,al,ad,au,a1,a2,au,a1,a2)

!
!     recover tendencies of heat and moisture
!
      do  k = 1,km
        do i = 1,im
          ttend      = (a1(i,k)-t1(i,k))   * rdt
          qtend      = (a2(i,k)-q1(i,k,1)) * rdt
          tau(i,k)   = tau(i,k)   + ttend
          rtg(i,k,1) = rtg(i,k,1) + qtend
          dtsfc(i)   = dtsfc(i)   + del(i,k)*ttend
          dqsfc(i)   = dqsfc(i)   + del(i,k)*qtend
        enddo
      enddo
      if(ldiag3d .and. .not. gen_tend) then
        idtend = dtidx(index_of_temperature,index_of_process_pbl)
        if(idtend>=1) then
          dtend(:,:,idtend) = dtend(:,:,idtend) + (a1-t1)
        endif
        idtend = dtidx(ntqv+100,index_of_process_pbl)
        if(idtend>=1) then
          dtend(:,:,idtend) = dtend(:,:,idtend) + a2-q1(:,:,1)
        endif
      endif
      do i = 1,im
        dtsfc(i)   = dtsfc(i) * cont
        dqsfc(i)   = dqsfc(i) * conq
      enddo
      if(ntrac > 1) then
        is = 0
        do kk = 2, ntrac
          if (kk /= ntke) then
            is = is + km
            do k = 1, km
              do i = 1, im
                qtend = (a2(i,k+is)-q1(i,k,kk))*rdt
                rtg(i,k,kk) = rtg(i,k,kk) + qtend
              enddo
            enddo
          endif
        enddo
        if(ldiag3d .and. ntoz>0 .and. .not. gen_tend) then
          idtend=dtidx(100+ntoz,index_of_process_pbl)
          if(idtend>=1) then
            kk = ntoz
            is = (kk-1) * km
            do k = 1, km
              do i = 1, im
                qtend = (a2(i,k+is)-q1(i,k,kk))
                dtend(i,k,idtend) = dtend(i,k,idtend) + qtend
              enddo
            enddo
          endif
        endif
      endif
!
!     compute tridiagonal matrix elements for momentum
!
      do i=1,im
         ad(i,1) = one + beta(i) * stress(i) / spd1(i)
         a1(i,1) = u1(i,1)
         a2(i,1) = v1(i,1)
      enddo
!
      do k = 1,km1
        kp1 = k + 1
        do i=1,im
          dtodsd    = dt2odel(i,k)
          dtodsu    = dt2odel(i,kp1)
          dsig      = prsl(i,k)-prsl(i,kp1)
          rdz       = rdzt(i,k)
          tem1      = dsig*dku(i,k)*rdz
          dsdz2     = tem1 * rdz
          au(i,k)   = -dtodsd*dsdz2
          al(i,k)   = -dtodsu*dsdz2
!
          ad(i,k)   = ad(i,k) - au(i,k)
          ad(i,kp1) = one - al(i,k)
          a1(i,kp1) = u1(i,kp1)
          a2(i,kp1) = v1(i,kp1)
!
        enddo
      enddo

      call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2)
!
!     recover tendencies of momentum
!
      do k = 1,km
        do i = 1,im
          utend    = (a1(i,k)-u1(i,k))*rdt
          vtend    = (a2(i,k)-v1(i,k))*rdt
          du(i,k)  = du(i,k)  + utend
          dv(i,k)  = dv(i,k)  + vtend
          tem      = del(i,k) * gravi
          dusfc(i) = dusfc(i) + tem * utend
          dvsfc(i) = dvsfc(i) + tem * vtend
        enddo
      enddo
      if (ldiag3d .and. .not. gen_tend) then
        idtend = dtidx(index_of_x_wind,index_of_process_pbl)
        if(idtend>=1) then
          dtend(:,:,idtend) = dtend(:,:,idtend) + a1-u1
        endif
        idtend = dtidx(index_of_y_wind,index_of_process_pbl)
        if(idtend>=1) then
          dtend(:,:,idtend) = dtend(:,:,idtend) + a1-v1
        endif
      endif
!
      if (ntke > 0) then    ! solve tridiagonal problem for momentum and tke
!
!     compute tridiagonal matrix elements for tke
!
        do i=1,im
           ad(i,1) = one
           a1(i,1) = q1(i,1,ntke)
        enddo
!
        do k = 1,km1
          kp1 = k + 1
          do i=1,im
            dtodsd    = dt2odel(i,k)
            dtodsu    = dt2odel(i,kp1)
            dsig      = prsl(i,k)-prsl(i,kp1)
            rdz       = rdzt(i,k)
            tem1      = dsig*dku(i,k)*(rdz+rdz)
            dsdz2     = tem1 * rdz
            au(i,k)   = -dtodsd*dsdz2
            al(i,k)   = -dtodsu*dsdz2
!
            ad(i,k)   = ad(i,k) - au(i,k)
            ad(i,kp1) = one - al(i,k)
            a1(i,kp1) = q1(i,kp1,ntke)
          enddo
        enddo

        call tridi1(im,km,al,ad,au,a1,au,a1)
!
        do k = 1, km !     recover tendencies of tke
          do i = 1, im
            qtend = (a1(i,k)-q1(i,k,ntke))*rdt
            rtg(i,k,ntke) = rtg(i,k,ntke) + qtend
          enddo
        enddo
      endif
!
      return
      end subroutine moninshoc_run

      end module moninshoc