!//=========================================================================
!// Oslo CTM3
!//=========================================================================
!// Based on UCI CTM core p-7.1 (1/2013).
!//
!// Ole Amund Sovde, April 2015
!//=========================================================================
!// Source routine ala UCI (sources as separate process).
!//=========================================================================
module source_uci
  !//-----------------------------------------------------------------------
  !// MODULE: source_uci
  !// DESCRIPTION: Routine to emit species into tracer array, i.e.
  !//              as a separate process.
  !//
  !// Contains
  !//   subroutine SOURCE
  !//-----------------------------------------------------------------------
  implicit none
  !//-----------------------------------------------------------------------
  character(len=*), parameter, private :: f90file = 'source_uci.f90'
  !// ----------------------------------------------------------------------
  public
  !//-----------------------------------------------------------------------

contains

  !//-----------------------------------------------------------------------
  subroutine SOURCE (BTT,BXT,BXX,BYT,BYY,BXY,BZT,DTSRCE,MP)
    !//---------------------------------------------------------------------
    !//---------------------------------------------------------------------
    use cmn_precision, only: r8, rMom
    use cmn_size, only: IPAR, LPAR, NPAR, IDBLK, JDBLK, LEMISDEP_INCHEM, &
         NE2DS
    use cmn_ctm, only: JMON, JDATE, NTM, GMTAU, MPBLKIB, MPBLKIE, &
         MPBLKJB, MPBLKJE, LMMAP, ETAA, ETAB
    use cmn_chem, only: NE2TBL, NY2TBL, NM2TBL, E2LTBL, E2STBL, E2DS, &
                        NE3TBL, NY3TBL, NM3TBL, E3LTBL, E3STBL, E3DSNEW, &
                        NEMLIT, NLIT, LITSRC, LITFAC, TNAME
    use cmn_met, only: MYEAR, SFU, SFV, LBLH, P, ZOFLE
    use cmn_oslo, only: trsp_idx, FF_TYPE, NEFIR, &
         ECOMP_FIR, EMIS_FIR, EPAR_FIR_LM, &
         E2CTBL, E2LocHourTBL, E2LocHourSCALE, &
         E2vertTBL, NE2vertLVS, E2vertSCALE
    use sulphur_oslo, only: DMSseaconc
    use emissions_aircraft, only: EPAR_AC, ECOMP_TRNR, EMIS_AC
    use emissions_megan, only: add_meganBiogenic
    use emissions_ocean, only: add_oceanOCemis
    use emissions_volcanoes, only: add_volcEMIS
    !//---------------------------------------------------------------------
    implicit none
    !//---------------------------------------------------------------------
    !// Input
    integer, intent(in) :: MP
    real(r8), intent(in) :: DTSRCE
    !// Input/Output
    real(r8), intent(inout), dimension(LPAR,NPAR,IDBLK,JDBLK) :: BTT
    real(rMom), intent(inout), dimension(LPAR,NPAR,IDBLK,JDBLK) :: &
         BXT, BXX, BYT, BYY, BXY, BZT

    !// Locals
    real(r8) :: ADDTC, ZNR, E2DS6(6)
    real(r8) :: DT
    real(r8) :: vv, rk600, zhr !// DMS short term variations
    integer :: I,II, J,JJ, L, N, NN, M, MM, LOCHR
    real(r8) :: local_hour(IDBLK), dPtot, P1, P2, ztot, Z1, Z2, &
         SCALING, SCALLIGHT
    real(r8), parameter :: LOCDT = 24.d0 / IPAR
    !//---------------------------------------------------------------------
    character(len=*), parameter :: subr = 'SOURCE'
    !// --------------------------------------------------------------------

    !// Swich for Oslo chemistry treatment of emissions. If they are to
    !// be treated as production terms in chemistry, they will be fetched
    !// in oc_main.f, so we just return from here.
    if (LEMISDEP_INCHEM) return

    !// All emissions are kg/s
    DT = DTSRCE

    !// Local hours for IDBLK indices
    do I = MPBLKIB(MP), MPBLKIE(MP)
       II   = I - MPBLKIB(MP) + 1
       !// Find local hour LOCHR in grid box i (+1 to get index).
       local_hour(II) = mod((GMTAU + LOCDT*real(i-1,r8)),24._r8) + 1._r8
    end do

    !// Changed the loop order; loop first over emission tables, then
    !// in the order J,I,N

    !// 2D emissions (monthly or yearly)
    !//---------------------------------------------------------------------
    if (NE2DS .eq. 6)  then
      !// 2D tables and tracers:  find non-zero emission factors
      do M = 1, NE2TBL
        !// Skip emissions if year does not match year-table
        if (.not. (NY2TBL(M) .eq. MYEAR .or. NY2TBL(M) .eq. 9999)) cycle

        if (NM2TBL(M) .eq. JMON .or. NM2TBL(M) .eq. 99) then

          do J = MPBLKJB(MP), MPBLKJE(MP)
            JJ   = J - MPBLKJB(MP) + 1
            do I = MPBLKIB(MP), MPBLKIE(MP)
              II   = I - MPBLKIB(MP) + 1
              do N = 1, NTM
                !// Check if emission set is used by tracer N
                if (E2LTBL(N,M)) then
                  !// Get emissions and moments
                  do NN = 1, NE2DS
                    E2DS6(NN) = E2DS(I,J,NN,M)
                  end do
                  !// Scale with scaling factor for N & M
                  ADDTC = DT * E2STBL(N,M) * E2DS6(1)
                  !// Add scaling for diurnal variations
                  if (E2LocHourTBL(M).gt. 0) then
                    !// Find local hour LOCHR in grid box i (+1 to get index).
                    LOCHR = mod(int(GMTAU + LOCDT*(i-1)),24) + 1
                    !// Category number for table is E2CTBL(M)
                    !// Diurnal number for table is E2LocHourTBL(M)
                    ADDTC = ADDTC * E2LocHourSCALE(LOCHR,E2CTBL(M),E2LocHourTBL(M))
                  end if

                  !// Distribute vertically on E2vertLVS layers or not
                  if (E2vertTBL(M) .eq. 0) then
                     !// Put all in surface level (L=1)
                     BTT(1,N,II,JJ) = BTT(1,N,II,JJ) + ADDTC
                     BXT(1,N,II,JJ) = BXT(1,N,II,JJ) + ADDTC * E2DS6(2)
                     BXX(1,N,II,JJ) = BXX(1,N,II,JJ) + ADDTC * E2DS6(3)
                     BYT(1,N,II,JJ) = BYT(1,N,II,JJ) + ADDTC * E2DS6(4)
                     BYY(1,N,II,JJ) = BYY(1,N,II,JJ) + ADDTC * E2DS6(5)
                     BXY(1,N,II,JJ) = BXY(1,N,II,JJ) + ADDTC * E2DS6(6)
                  else
                     !// Distribute in some near-surface levels
                     !// Thickness (m) ca 0-16,16-41,41-77,77-128
                     !// Use LMMAP in case of collapsed layers near surface.
                     do L = 1, NE2vertLVS
                        BTT(LMMAP(L),N,II,JJ) = BTT(LMMAP(L),N,II,JJ) &
                             + ADDTC * E2vertSCALE(L,E2vertTBL(M))
                        BXT(LMMAP(L),N,II,JJ) = BXT(LMMAP(L),N,II,JJ) &
                             + ADDTC * E2DS6(2) * E2vertSCALE(L,E2vertTBL(M))
                        BXX(LMMAP(L),N,II,JJ) = BXX(LMMAP(L),N,II,JJ) &
                             + ADDTC * E2DS6(3) * E2vertSCALE(L,E2vertTBL(M))
                        BYT(LMMAP(L),N,II,JJ) = BYT(LMMAP(L),N,II,JJ) &
                             + ADDTC * E2DS6(4) * E2vertSCALE(L,E2vertTBL(M))
                        BYY(LMMAP(L),N,II,JJ) = BYY(LMMAP(L),N,II,JJ) &
                             + ADDTC * E2DS6(5) * E2vertSCALE(L,E2vertTBL(M))
                        BXY(LMMAP(L),N,II,JJ) = BXY(LMMAP(L),N,II,JJ) &
                             + ADDTC * E2DS6(6) * E2vertSCALE(L,E2vertTBL(M))
                     end do
                  end if

                end if
              end do
            end do !// do I = MPBLKIB(MP),MPBLKIE(MP)
          end do !// do J = MPBLKJB(MP),MPBLKJE(MP)
        end if
      end do
    else  ! 2-D emission mass only
      do M = 1, NE2TBL
        !// Skip emissions if year does not match year-table
        if (.not. (NY2TBL(M) .eq. MYEAR .or. NY2TBL(M) .eq. 9999)) cycle

        if (NM2TBL(M) .eq. JMON .or. NM2TBL(M) .eq. 99) then
          do J = MPBLKJB(MP), MPBLKJE(MP)
            JJ   = J - MPBLKJB(MP) + 1
            do I = MPBLKIB(MP), MPBLKIE(MP)
              II   = I - MPBLKIB(MP) + 1
              do N = 1, NTM
                if (E2LTBL(N,M))  then
                  !// Scale with scaling factor for N & M
                  ADDTC = DT * E2STBL(N,M) * E2DS(I,J,1,M)
                  !// Add scaling for diurnal variations
                  if (E2LocHourTBL(M).gt. 0) then
                    !// Find local hour LOCHR in grid box i (+1 to get index).
                    LOCHR = mod(int(GMTAU + LOCDT*(i-1)),24) + 1
                    !// Category number for table is E2CTBL(M)
                    !// Diurnal number for table is E2LocHourTBL(M)
                    ADDTC = ADDTC * E2LocHourSCALE(LOCHR,E2CTBL(M),E2LocHourTBL(M))
                  end if

                  !// Distribute vertically on E2vertLVS layers or not
                  if (E2vertTBL(M) .eq. 0) then
                     !// Put all in surface level (L=1)
                     BTT(1,N,II,JJ) = BTT(1,N,II,JJ) + ADDTC
                  else
                     !// Distribute in some near-surface levels
                     !// Thickness (m) ca 0-16,16-41,41-77,77-128
                     !// Use LMMAP in case of collapsed layers near surface.
                     do L = 1, NE2vertLVS
                        BTT(LMMAP(L),N,II,JJ) = BTT(LMMAP(L),N,II,JJ) &
                             + ADDTC * E2vertSCALE(L,E2vertTBL(M))
                     end do
                  end if

                end if
              end do
            end do !// do I = MPBLKIB(MP),MPBLKIE(MP)
          end do !// do J = MPBLKJB(MP),MPBLKJE(MP)
        end if
      end do
    end if

    !// 3D emissions (monthly or yearly)
    !//---------------------------------------------------------------------
    !// 3D tables and tracers:  find non-zero emission factors
    do M = 1, NE3TBL
      !// Skip emissions if year does not match year-table
      if (.not. (NY3TBL(M) .eq. MYEAR .or. NY3TBL(M) .eq. 9999)) cycle

      if (NM3TBL(M) .eq. JMON .or. NM3TBL(M) .eq. 99) then
        do J = MPBLKJB(MP), MPBLKJE(MP)
          JJ   = J - MPBLKJB(MP) + 1
          do I = MPBLKIB(MP), MPBLKIE(MP)
            II   = I - MPBLKIB(MP) + 1
            do N = 1, NTM
              if (E3LTBL(N,M))  then
                do L = 1, LPAR
                  !// Scale with scaling factor for N & M
                  ADDTC = DT * E3STBL(N,M) * E3DSNEW(L,I,J,M)
                  !// Put source in L=1, no moments:
                  BTT(L,N,II,JJ) = BTT(L,N,II,JJ) + ADDTC
                end do
              end if
            end do
          end do !// do I = MPBLKIB(MP),MPBLKIE(MP)
        end do !// do J = MPBLKJB(MP),MPBLKJE(MP)
      end if
    end do

    !// Forest fires (short term variations)
    !//---------------------------------------------------------------------
    if (FF_TYPE.gt. 0) then
      !// Forest fires are included.
      do J = MPBLKJB(MP), MPBLKJE(MP)
        JJ = J - MPBLKJB(MP) + 1
        do I = MPBLKIB(MP), MPBLKIE(MP)
          II = I - MPBLKIB(MP) + 1

          !// Following Roberts et al. (2009, doi: 10.5194/bg-6-849-2009),
          !// we emit more between 7 and 19 local time.
          !// First estimate is 50% at night and 150% during day.
          !// Roberts et al. may suggest even more during day.
          if (local_hour(II) .ge. 7._r8 .and. local_hour(II) .lt. 19._r8) then
             !SCALLIGHT = 1.5_r8 ! Emit 50% more for 7-19
             SCALLIGHT = 1.9_r8 ! Emit 90% more for 7-19
             !SCALLIGHT = 1.0_r8 ! Emit 100% for 7-19
          else
             !SCALLIGHT = 0.5_r8 ! Emit 50% for 19-7
             SCALLIGHT = 0.1_r8 ! Emit 10% for 19-7
             !SCALLIGHT = 1.0_r8 ! Emit 100% for 19-7
          end if

          do MM = 1, NEFIR
            !// Get transport number of component emitted
            N = ECOMP_FIR(MM)
            !// Skip if not included
            if (N .le. 0) cycle

            !// Put into BTT

            if (FF_TYPE .eq. 6 .or. FF_TYPE .eq. 7) then
               !// Distribute emissions in PBL, according to air mass.
               !// Combined with putting all into L=1 of EMIS_FIR

               !// Distribute emissions according to air mass
               P2 = ETAA(1) + ETAB(1) * P(I,J) ! Will use this in loop below
               P1 = ETAA(LBLH(I,J) + 1) + ETAB(LBLH(I,J) + 1) * P(I,J) !// Top of LBLH
               dPtot = P2 - P1
               if (dPtot .le. 0._r8) then
                  write(6,'(a,2es14.5,i5)') f90file//':'//subr// &
                       ': dPtot <= 0: ',P2,P1, LBLH(I,J)
                  stop
               end if
               do L = 1, LBLH(I,J)
                  P1 = P2 !// i.e. ETAA(L) + ETAB(L) * P(I,J), bottom of layer
                  P2 = ETAA(L+1) + ETAB(L+1) * P(I,J) !// Top of layer
                  SCALING = SCALLIGHT * (P1 - P2) / dPtot
                  if (SCALING .lt. 0._r8) then
                     write(6,'(a,3es14.5,i5)') f90file//':'//subr// &
                          ': SCALING IS NEGATIVE',P2,P1,dPtot, LBLH(I,J)
                     stop
                  end if
                  !// Put into emission array, level L
                  BTT(L,N,II,JJ) = BTT(L,N,II,JJ) &
                       + EMIS_FIR(1,MM,II,JJ,MP) * SCALING * DT
               end do !// do L = 1, LBLH(I,J)
            else if (FF_TYPE .eq. 8 .or. FF_TYPE .eq. 9 &
                 .or. FF_TYPE .eq. 51) then
               !// Distribute emissions in PBL, according to dZ.
               !// Combined with putting all into L=1 of EMIS_FIR

               !// Distribute emissions according to air mass
               Z2 = ZOFLE(1,I,J)    ! Will use this in loop below
               Z1 = ZOFLE(LBLH(I,J)+1,I,J) !// Top of LBLH
               ztot = Z1 - Z2
               do L = 1, LBLH(I,J)
                  Z1 = Z2 !// i.e. ZOFLE(L,I,J) bottom of layer
                  Z2 = ZOFLE(L+1,I,J) !// Top of layer
                  SCALING = SCALLIGHT * (Z2 - Z1) / ztot
                  !// Put into emission array, level L
                  BTT(L,N,II,JJ) = BTT(L,N,II,JJ) &
                       + EMIS_FIR(1,MM,II,JJ,MP) * SCALING * DT
               end do !// do L = 1, LBLH(I,J)

            else
               !// Use vertical predefined distribution
               do L = 1, EPAR_FIR_LM
                  BTT(L,N,II,JJ) = BTT(L,N,II,JJ) &
                       + EMIS_FIR(L,MM,II,JJ,MP) * SCALLIGHT * DT
               end do !// do L = 1,EPAR_FIR_LM
            end if

          end do
        end do
      end do
    end if

    !// Lightning emissions:
    !// LITSRC is determined for each met field - called by main
    !//---------------------------------------------------------------------
    if (NEMLIT.gt. 0) then
      !// LITSRC is fraction of annual emissions per second.
      !// LITFAC(M) scales the fraction/s to kg/s.
      do M = 1, NEMLIT
        N  = NLIT(M)
        do J = MPBLKJB(MP), MPBLKJE(MP)
          JJ = J - MPBLKJB(MP) + 1
          do I = MPBLKIB(MP), MPBLKIE(MP)
            II = I - MPBLKIB(MP) + 1
            do L = 1, LPAR
              !// CTM3: reverse order for LITSRC
              BTT(L,N,II,JJ) = BTT(L,N,II,JJ) &
                   + LITSRC(L,I,J) * LITFAC(M) & !// kg/s
                     * DT
            end do
          end do
        end do
      end do
    end if

    !// Aircraft emissions:
    !//---------------------------------------------------------------------
    do M = 1, EPAR_AC
      N = ECOMP_TRNR(M)
      if (N .gt. 0) then
        !// Component is included
        do J = MPBLKJB(MP), MPBLKJE(MP)
          JJ = J - MPBLKJB(MP) + 1
          do I = MPBLKIB(MP), MPBLKIE(MP)
            II = I - MPBLKIB(MP) + 1
            do L = 1, LPAR
              !// Emissions are kg/s
              ADDTC = EMIS_AC(L,M,II,JJ,MP) * DT
              !// Put into emission array, level L
              BTT(L,N,II,JJ) = BTT(L,N,II,JJ) + ADDTC
            end do
          end do
        end do
      end if
    end do

    !// Other short term variations (STV)
    !//---------------------------------------------------------------------
    !// DMS
    do N = 1, NPAR
      if (TNAME(N) .eq. 'DMS') then
        zhr = 1._r8 / 3600._r8
        do J = MPBLKJB(MP), MPBLKJE(MP)
          JJ = J - MPBLKJB(MP) + 1
          do I = MPBLKIB(MP), MPBLKIE(MP)
            II = I - MPBLKIB(MP) + 1
            vv = SFU(I,J)**2 + SFV(I,J)**2 !// "10m" wind squared
            !// Velocity based on Nightingale et al., Global Biogeochemical
            !// Cycles vol.14, no.1, p 373-387, 2000
            !// Change from cm/hr to m/s
            rk600 = (0.222_r8*vv + 0.333_r8*vv**0.5_r8) * 1.e-2_r8 * zhr
            !// Scale DMSseaconc from kg/m to kg/s and add to tracer array.
            ADDTC = DT * rk600 * DMSseaconc(I,J,JMON)
            BTT(1,N,II,JJ) = BTT(1,N,II,JJ) + ADDTC
          end do
        end do
        exit !// Done DMS
      end if
    end do

    !// Volcanoes SO2 from HTAP or other dataset.
    !//---------------------------------------------------------------------
    !// Added directly to BTT.
    call add_volcEMIS(BTT,DT,JDATE,JMON,MP)

    !// Oceanic carbon emissions
    call add_oceanOCemis(BTT,DT,MP)

    !// Biogenic emissions (MEGANv2.10)
    call add_meganBiogenic(BTT,DT,MP)

    !//---------------------------------------------------------------------
  end subroutine SOURCE
  !//-----------------------------------------------------------------------

  !//-----------------------------------------------------------------------
end module source_uci
!//=========================================================================


C
C $Id: tdlbls.f,v 1.4 2008-07-27 00:17:32 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE TDLBLS (UMIN,VMIN,WMIN,UMAX,VMAX,WMAX,
     +                   UNLB,VNLB,WNLB,UILB,VILB,WILB,IPCK)
C
        CHARACTER*(*) UILB,VILB,WILB,UNLB,VNLB,WNLB
C
C This routine may be called to label the axes of the box in 3-space
C within which a surface is being drawn.  Its arguments are as follows:
C
C   UMIN, VMIN, WMIN, UMAX, VMAX, and WMAX are real input values, each
C   of which specifies one of the coordinate values defining the box in
C   3-space.  The names of these should make it clear what they are.
C
C   UNLB, VNLB, and WNLB are character strings containing numeric labels
C   to be placed on a U axis, a V axis, or a W axis, respectively.  The
C   labels need not be in any particular order, but they have to be
C   separated by blanks and each has to be readable using a FORTRAN
C   format of the form "En.0", where "n" is the length of the label.
C
C   UILB, VILB, and WILB are character strings containing informational
C   labels for a U axis, a V axis, or a W axis, respectively.
C
C   IPCK is an input integer determining which edges of the box are
C   labelled.  If IPCK is zero, all six outer edges are labelled, but
C   if IPCK is non-zero, only three edges are labelled, one set of
C   three if IPCK is negative, a different set if IPCK is positive.
C
C Declare required TDPACK common blocks.
C
        COMMON /TDCOM1/ IH,IT,XM,YM,ZM,XO,YO,ZO,XT,YT,ZT,OE,XE,YE,ZE
        COMMON /TDCOM1/ A1,B1,C1,D1,E1,A2,B2,C2,D2,E2,A3,B3,C3,D3,E3
        COMMON /TDCOM1/ IS,FV,VL,VR,VB,VT,WL,WR,WB,WT
        SAVE   /TDCOM1/
C
        COMMON /TDCOM4/ CSM1,CSM2
        SAVE   /TDCOM4/
C
C Declare two variables in which to put logical values indicating which
C axes are to be labelled.
C
        LOGICAL IPGZ,IPLZ
C
C Compute logical values indicating which axes are to be labelled.
C
        IPGZ=IPCK.GE.0
        IPLZ=IPCK.LE.0
C
C Compute the coordinates of the center point of the box.
C
        UMID=.5*(UMIN+UMAX)
        VMID=.5*(VMIN+VMAX)
        WMID=.5*(WMIN+WMAX)
C
C Set the combined character size multiplier.  Note that all character
C widths are stated as fractions of the smallest dimension of the box.
C
        CSM2=CSM1*MIN(UMAX-UMIN,VMAX-VMIN,WMAX-WMIN)
C
C Left-handed and right-handed systems need to be treated differently.
C In each case, what we do depends on where the viewpoint (the point
C midway between the eyes in the case of a stereo view) is relative to
C the center of the box.
C
        IF (IH.EQ.0) THEN
          IF      (XM.GT.UMID.AND.YM.GT.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMAX,VMIN,WMIN,0.,+1.,0.,-1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (3,VILB,VNLB,VMIN,VMAX,UMAX,UMIN,  0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,VMIN,VMAX,UMAX,UMIN, 90.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,+1.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,VMIN,VMAX,WMIN,WMAX, 90.)
            IF (IPLZ) CALL TDLBLA (4,VILB,VNLB,VMIN,VMAX,WMIN,WMAX,  0.)
            CALL TDPARA (UMAX,VMIN,WMIN,-1.,0.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMAX,UMIN,WMIN,WMAX,  0.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,UMAX,UMIN,WMIN,WMAX,-90.)
          ELSE IF (XM.LE.UMID.AND.YM.GT.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMAX,VMAX,WMIN,-1.,0.,0.,0.,-1.,0.)
            IF (IPGZ) CALL TDLBLA (3,UILB,UNLB,UMAX,UMIN,VMAX,VMIN,  0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,UMAX,UMIN,VMAX,VMIN, 90.)
            CALL TDPARA (UMAX,VMIN,WMIN,-1.,0.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,UMAX,UMIN,WMIN,WMAX, 90.)
            IF (IPLZ) CALL TDLBLA (4,UILB,UNLB,UMAX,UMIN,WMIN,WMAX,  0.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,-1.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMAX,VMIN,WMIN,WMAX,  0.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,VMAX,VMIN,WMIN,WMAX,-90.)
          ELSE IF (XM.GT.UMID.AND.YM.LE.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMIN,VMIN,WMIN,+1.,0.,0.,0.,+1.,0.)
            IF (IPGZ) CALL TDLBLA (3,UILB,UNLB,UMIN,UMAX,VMIN,VMAX,  0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,UMIN,UMAX,VMIN,VMAX, 90.)
            CALL TDPARA (UMIN,VMAX,WMIN,+1.,0.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,UMIN,UMAX,WMIN,WMAX, 90.)
            IF (IPLZ) CALL TDLBLA (4,UILB,UNLB,UMIN,UMAX,WMIN,WMAX,  0.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,+1.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMIN,VMAX,WMIN,WMAX,  0.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,VMIN,VMAX,WMIN,WMAX,-90.)
          ELSE IF (XM.LE.UMID.AND.YM.LE.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMIN,VMAX,WMIN,0.,-1.,0.,+1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (3,VILB,VNLB,VMAX,VMIN,UMIN,UMAX,  0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,VMAX,VMIN,UMIN,UMAX, 90.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,-1.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,VMAX,VMIN,WMIN,WMAX, 90.)
            IF (IPLZ) CALL TDLBLA (4,VILB,VNLB,VMAX,VMIN,WMIN,WMAX,  0.)
            CALL TDPARA (UMIN,VMAX,WMIN,+1.,0.,0.,0.,0.,+1.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMIN,UMAX,WMIN,WMAX,  0.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,UMIN,UMAX,WMIN,WMAX,-90.)
          ELSE IF (XM.GT.UMID.AND.YM.GT.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMIN,VMIN,WMAX,0.,+1.,0.,+1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,VMIN,VMAX,UMIN,UMAX,-90.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMIN,VMAX,UMIN,UMAX,  0.)
            CALL TDPARA (UMAX,VMIN,WMIN,-1.,0.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,UMAX,UMIN,WMIN,WMAX, 90.)
            IF (IPGZ) CALL TDLBLA (3,UILB,UNLB,UMAX,UMIN,WMIN,WMAX,  0.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,+1.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (3,VILB,VNLB,VMIN,VMAX,WMIN,WMAX,  0.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,VMIN,VMAX,WMIN,WMAX,-90.)
          ELSE IF (XM.LE.UMID.AND.YM.GT.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMAX,VMIN,WMAX,-1.,0.,0.,0.,+1.,0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,UMAX,UMIN,VMIN,VMAX,-90.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMAX,UMIN,VMIN,VMAX,  0.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,-1.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,VMAX,VMIN,WMIN,WMAX, 90.)
            IF (IPGZ) CALL TDLBLA (3,VILB,VNLB,VMAX,VMIN,WMIN,WMAX,  0.)
            CALL TDPARA (UMAX,VMIN,WMIN,-1.,0.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (3,UILB,UNLB,UMAX,UMIN,WMIN,WMAX,  0.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,UMAX,UMIN,WMIN,WMAX,-90.)
          ELSE IF (XM.GT.UMID.AND.YM.LE.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMIN,VMAX,WMAX,+1.,0.,0.,0.,-1.,0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,UMIN,UMAX,VMAX,VMIN,-90.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMIN,UMAX,VMAX,VMIN,  0.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,+1.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,VMIN,VMAX,WMIN,WMAX, 90.)
            IF (IPGZ) CALL TDLBLA (3,VILB,VNLB,VMIN,VMAX,WMIN,WMAX,  0.)
            CALL TDPARA (UMIN,VMAX,WMIN,+1.,0.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (3,UILB,UNLB,UMIN,UMAX,WMIN,WMAX,  0.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,UMIN,UMAX,WMIN,WMAX,-90.)
          ELSE IF (XM.LE.UMID.AND.YM.LE.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMAX,VMAX,WMAX,0.,-1.,0.,-1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,VMAX,VMIN,UMAX,UMIN,-90.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMAX,VMIN,UMAX,UMIN,  0.)
            CALL TDPARA (UMIN,VMAX,WMIN,+1.,0.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (1,WILB,WNLB,UMIN,UMAX,WMIN,WMAX, 90.)
            IF (IPGZ) CALL TDLBLA (3,UILB,UNLB,UMIN,UMAX,WMIN,WMAX,  0.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,-1.,0.,0.,0.,+1.)
            IF (IPLZ) CALL TDLBLA (3,VILB,VNLB,VMAX,VMIN,WMIN,WMAX,  0.)
            IF (IPGZ) CALL TDLBLA (2,WILB,WNLB,VMAX,VMIN,WMIN,WMAX,-90.)
          END IF
        ELSE
          IF      (XM.GT.UMID.AND.YM.GT.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMAX,VMIN,WMIN,-1.,0.,0.,0.,+1.,0.)
            IF (IPLZ) CALL TDLBLA (1,VILB,VNLB,UMAX,UMIN,VMIN,VMAX,-90.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMAX,UMIN,VMIN,VMAX,180.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,0.,+1.,0.,+1.,0.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,VMIN,VMAX,180.)
            IF (IPGZ) CALL TDLBLA (2,VILB,VNLB,WMIN,WMAX,VMIN,VMAX,-90.)
            CALL TDPARA (UMAX,VMIN,WMIN,0.,0.,+1.,-1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,WMIN,WMAX,UMAX,UMIN,-90.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,UMAX,UMIN,  0.)
          ELSE IF (XM.LE.UMID.AND.YM.GT.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMAX,VMAX,WMIN,0.,-1.,0.,-1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (1,UILB,UNLB,VMAX,VMIN,UMAX,UMIN,-90.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMAX,VMIN,UMAX,UMIN,180.)
            CALL TDPARA (UMAX,VMIN,WMIN,0.,0.,+1.,-1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,UMAX,UMIN,180.)
            IF (IPGZ) CALL TDLBLA (2,UILB,UNLB,WMIN,WMAX,UMAX,UMIN,-90.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,0.,+1.,0.,-1.,0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,WMIN,WMAX,VMAX,VMIN,-90.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,VMAX,VMIN,  0.)
          ELSE IF (XM.GT.UMID.AND.YM.LE.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMIN,VMIN,WMIN,0.,+1.,0.,+1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (1,UILB,UNLB,VMIN,VMAX,UMIN,UMAX,-90.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMIN,VMAX,UMIN,UMAX,180.)
            CALL TDPARA (UMIN,VMAX,WMIN,0.,0.,+1.,+1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,UMIN,UMAX,180.)
            IF (IPGZ) CALL TDLBLA (2,UILB,UNLB,WMIN,WMAX,UMIN,UMAX,-90.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,0.,+1.,0.,+1.,0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,WMIN,WMAX,VMIN,VMAX,-90.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,VMIN,VMAX,  0.)
          ELSE IF (XM.LE.UMID.AND.YM.LE.VMID.AND.ZM.GT.WMID) THEN
            CALL TDPARA (UMIN,VMAX,WMIN,+1.,0.,0.,0.,-1.,0.)
            IF (IPLZ) CALL TDLBLA (1,VILB,VNLB,UMIN,UMAX,VMAX,VMIN,-90.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMIN,UMAX,VMAX,VMIN,180.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,0.,+1.,0.,-1.,0.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,VMAX,VMIN,180.)
            IF (IPGZ) CALL TDLBLA (2,VILB,VNLB,WMIN,WMAX,VMAX,VMIN,-90.)
            CALL TDPARA (UMIN,VMAX,WMIN,0.,0.,+1.,+1.,0.,0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,WMIN,WMAX,UMIN,UMAX,-90.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,UMIN,UMAX,  0.)
          ELSE IF (XM.GT.UMID.AND.YM.GT.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMIN,VMIN,WMAX,+1.,0.,0.,0.,+1.,0.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMIN,UMAX,VMIN,VMAX,  0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,UMIN,UMAX,VMIN,VMAX,-90.)
            CALL TDPARA (UMAX,VMIN,WMIN,0.,0.,+1.,-1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,UMAX,UMIN,180.)
            IF (IPLZ) CALL TDLBLA (1,UILB,UNLB,WMIN,WMAX,UMAX,UMIN,-90.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,0.,+1.,0.,+1.,0.)
            IF (IPGZ) CALL TDLBLA (1,VILB,VNLB,WMIN,WMAX,VMIN,VMAX,-90.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,VMIN,VMAX,  0.)
          ELSE IF (XM.LE.UMID.AND.YM.GT.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMAX,VMIN,WMAX,0.,+1.,0.,-1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMIN,VMAX,UMAX,UMIN,  0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,VMIN,VMAX,UMAX,UMIN,-90.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,0.,+1.,0.,-1.,0.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,VMAX,VMIN,180.)
            IF (IPLZ) CALL TDLBLA (1,VILB,VNLB,WMIN,WMAX,VMAX,VMIN,-90.)
            CALL TDPARA (UMAX,VMIN,WMIN,0.,0.,+1.,-1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (1,UILB,UNLB,WMIN,WMAX,UMAX,UMIN,-90.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,UMAX,UMIN,  0.)
          ELSE IF (XM.GT.UMID.AND.YM.LE.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMIN,VMAX,WMAX,0.,-1.,0.,+1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (4,VILB,VNLB,VMAX,VMIN,UMIN,UMAX,  0.)
            IF (IPLZ) CALL TDLBLA (2,UILB,UNLB,VMAX,VMIN,UMIN,UMAX,-90.)
            CALL TDPARA (UMIN,VMIN,WMIN,0.,0.,+1.,0.,+1.,0.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,VMIN,VMAX,180.)
            IF (IPLZ) CALL TDLBLA (1,VILB,VNLB,WMIN,WMAX,VMIN,VMAX,-90.)
            CALL TDPARA (UMIN,VMAX,WMIN,0.,0.,+1.,+1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (1,UILB,UNLB,WMIN,WMAX,UMIN,UMAX,-90.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,UMIN,UMAX,  0.)
          ELSE IF (XM.LE.UMID.AND.YM.LE.VMID.AND.ZM.LE.WMID) THEN
            CALL TDPARA (UMAX,VMAX,WMAX,-1.,0.,0.,0.,-1.,0.)
            IF (IPGZ) CALL TDLBLA (4,UILB,UNLB,UMAX,UMIN,VMAX,VMIN,  0.)
            IF (IPLZ) CALL TDLBLA (2,VILB,VNLB,UMAX,UMIN,VMAX,VMIN,-90.)
            CALL TDPARA (UMIN,VMAX,WMIN,0.,0.,+1.,+1.,0.,0.)
            IF (IPGZ) CALL TDLBLA (3,WILB,WNLB,WMIN,WMAX,UMIN,UMAX,180.)
            IF (IPLZ) CALL TDLBLA (1,UILB,UNLB,WMIN,WMAX,UMIN,UMAX,-90.)
            CALL TDPARA (UMAX,VMAX,WMIN,0.,0.,+1.,0.,-1.,0.)
            IF (IPGZ) CALL TDLBLA (1,VILB,VNLB,WMIN,WMAX,VMAX,VMIN,-90.)
            IF (IPLZ) CALL TDLBLA (4,WILB,WNLB,WMIN,WMAX,VMAX,VMIN,  0.)
          END IF
        END IF
C
C Done.
C
        RETURN
C
      END


c     ****************************************************************
c     *                                                              *
c     *                      subroutine rktstf                       *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 9/5/2017  rhd              *
c     *                                                              *
c     *     drive computation of tangent stiffness matrices for a    *
c     *     block of similar elements.                               *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine rktstf( props, iprops, lprops, glb_ek_blk, nrow_ek,
     &                   ispan, local_work )
      use main_data, only : matprp, lmtprp, asymmetric_assembly
      implicit none
      include 'param_def'
      include 'include_tan_ek'
c
c                 parameter declarations
c
      integer :: nrow_ek  ! set for symmetric or asymmetric
      integer :: ispan
      double precision ::  glb_ek_blk(nrow_ek,ispan)
      real    :: props(mxelpr,*)   !  all 3 are same. read-only here
      integer :: iprops(mxelpr,*)  !  1st col is for felem
      logical :: lprops(mxelpr,*)
c
c                 local
c
      integer :: span, felem, utsz, iter, type, order, ngp, nnode,
     &           ndof, totdof, mat_type, surf, local_iout, gpn,
     &           nlength, i, i_local

      logical :: geonl, local_debug, bbar, first, qbar_flag,
     &           compute_shape, cohes_mirror, dummy_logic,
     &           average, symmetric_assembly
c
      double precision ::
     &  xi, eta, zeta, beta_fact, eps_bbar, zero, one, dummy,
     &  temp_ref, d_temp, temp_np1
c
      data local_debug, dummy_logic / .false., .true. /
      data zero, one, dummy / 0.d0, 1.d0, 1.d0 /
c
c
      local_iout = local_work%iout
      if( local_debug ) write(local_iout,9100)
c
c              set common properties for all elements in block
c
      span      = local_work%span
      felem     = local_work%felem
      utsz      = local_work%utsz
      beta_fact = local_work%beta_fact
      eps_bbar  = local_work%eps_bbar
      first     = local_work%first
      iter      = local_work%iter
      qbar_flag = local_work%qbar_flag
c
      type      = local_work%elem_type
      order     = local_work%int_order
      ngp       = local_work%num_int_points
      nnode     = local_work%num_enodes
      ndof      = local_work%num_enode_dof
      geonl     = local_work%geo_non_flg
      totdof    = nnode * ndof
      bbar      = local_work%bbar_flg
      mat_type  = local_work%mat_type
      surf       = local_work%surface
      compute_shape =  local_work%is_cohes_elem .or.
     &                 local_work%is_axisymm_elem .or.
     &                 local_work%fgm_enode_props
      symmetric_assembly = .not. asymmetric_assembly
c
      if( symmetric_assembly ) then
            allocate( local_work%ek_symm(span,nrow_ek) )
            local_work%ek_symm = zero
            allocate( local_work%ek_full(1,1) )  ! for safe passing
      else
            allocate( local_work%ek_full(span,nrow_ek) )
            local_work%ek_full = zero
            allocate( local_work%ek_symm(1,1) )
      end if
c
c      if( asymmetric_assembly ) ek = zero
c
c               compute all the shape function derivatives,
c               inverse coordinate jacobians and determinants.
c               get weight function values for gauss integration.
c               for bbar elements (8-node bricks) we also
c               the additional volume terms. for geonl,
c               we use the nodal coordinates updated to
c               n+1 to compute jacobians, bbar terms,etc.
c
      if( bbar .and. type .eq. 2 ) then
         call rktstf_zero_vol( local_work%vol_block,
     &                  local_work%volume_block, span, mxvl )
      end if
c
c             for cohesive elements the element coordinates and
c             the global displacements are rotated to a coordinate
c             system in which the normal axis (Z rotated) is
c             perpendicular to the referernce surface of the
c             cohesive element
c
      if( local_work%is_cohes_elem )  then
            call cohes_rot_mat( span, felem, nnode, type,
     &                          local_work%ce,
     &                          local_work%cohes_rot_block )
          if ( geonl )
     &      call cohes_mirror_refsurf( span, mxvl, totdof, nnode,
     &                                 local_work%ce )
      end if
c
      do gpn = 1, ngp
         call getgpts( type, order, gpn, xi, eta, zeta,
     &                 local_work%weights(gpn) )
         call derivs( type, xi, eta, zeta, local_work%nxi(1,gpn),
     &                local_work%neta(1,gpn), local_work%nzeta(1,gpn) )
         if( compute_shape )
     &      call shapef( type, xi, eta, zeta, local_work%shape(1,gpn) )
         call jacob1( type, span, felem, gpn, local_work%jac_block,
     &                local_work%det_jac_block(1,gpn),
     &                local_work%gama_block(1,1,1,gpn),
     &                local_work%cohes_rot_block,
     &                local_work%nxi(1,gpn), local_work%neta(1,gpn),
     &                local_work%nzeta(1,gpn), local_work%ce,
     &                nnode )
         if ( bbar ) then
           call vol_terms( local_work%gama_block(1,1,1,gpn),
     &                     local_work%det_jac_block(1,gpn),
     &                     local_work%vol_block, local_work%nxi(1,gpn),
     &                     local_work%neta(1,gpn),
     &                     local_work%nzeta(1,gpn),
     &                     local_work%volume_block,
     &                     span, mxvl )
         end if
      end do
c
      if( bbar ) call vol_avg( local_work%vol_block,
     &                          local_work%volume_block, span, mxvl )
c
c               generate tangent stiffnesses for elements
c               in block, one gauss point at a time. zero
c               [b] matrices used in computations for block -
c               lower routines fill in only non-zero terms.
c
      nlength = mxvl * mxedof * nstr
      call rktstf_zero_vec( local_work%b_block,  nlength )
      call rktstf_zero_vec( local_work%bd_block, nlength )
c
      do gpn = 1, ngp
         call gptns1( local_work%cp, local_work%icp, gpn, props,
     &                iprops, glb_ek_blk, local_work )
       end do
c
      if( symmetric_assembly ) then
          call rktstf_do_transpose( local_work%ek_symm, glb_ek_blk,
     &                              span, nrow_ek )
      else
        call rktstf_do_transpose(  local_work%ek_full, glb_ek_blk,
     &                            span, nrow_ek )
      end if
      deallocate( local_work%ek_symm, local_work%ek_full )
c
c               modify element stiffness matrix by thickness
c               factor for plane strain analysis
c
      if( beta_fact .ne. one ) glb_ek_blk = beta_fact * glb_ek_blk
c
c               transform element stiffnesses to constraint
c               compatible coordinates if required. skip
c               whole block or specfic element to reduce work.
c
      if( local_work%trn_e_block ) then
        do i = 1, span
           i_local = i
           if( local_work%trn_e_flags(i) )
     &         call trnmtx( glb_ek_blk, local_work%cp,
     &                      local_work%trnmte, local_work%trne, ndof,
     &                      nnode, totdof, i_local, nrow_ek )
         end do
      end if
c
      return
c
 9100 format(8x,'>> entered rktstf...' )
 9200 format(12x,'>> upper-triangular stiffnesses for elements',
     &   ' in block...')
 9210 format(3x,i8,1000(6e15.6,/11x))
 9400 format(1x,//,'>> Upper triangluar matrix:')
 9405 format(1x,'   element #',i7)
 9410 format(1x,'j=',i3,2x,'row=',i3,2x,'col=',i3,2x,'ek=',f25.8)
 9300 format(1x,////,
     & '  ELEMENT TESTING, values in rktstf.f',//,
     & '       span = ',i7,/,
     & '      nnode = ',i7,/,
     & '     totdof = ',i7,/,
     & '  elem_type = ',i7,/,
     & '      felem = ',i7,/,
     & '       utsz = ',i7,/)
 9500 format(1x,'>> Fatal Error: rktstf. invalid material type..',
     &    /, 1x,'                job terminated' )
c
      end
c
c     ****************************************************************
c     *                                                              *
c     *                   subroutine rktstf_do_transpose             *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 09/19/2016rhd              *
c     *                                                              *
c     ****************************************************************
c

      subroutine rktstf_do_transpose( local_ek, ek, span, nrow_ek )
      implicit none
c
      integer :: span, nrow_ek
      integer :: i, j
      double precision ::
     & local_ek(span,nrow_ek), ek(nrow_ek,span)
c
c                 time 4.59 secs, tanstf time 12.64
c
c       ek = transpose( local_ek )
c       return
c
c
c           time 2.22 secs,  for 1830  tanstf.f 12.73395100
c             when nrow_ek is used, 2.78 secs

c
      select case ( nrow_ek ) ! careful. type could be integer constant
c
      case( 300 )
        do j = 1, span
!DIR$ VECTOR ALIGNED
              do i = 1, 300
                    ek(i,j) = local_ek(j,i)
              end do
        end do
c
      case( 465 )
        do j = 1, span
!DIR$ VECTOR ALIGNED
              do i = 1, 465
                    ek(i,j) = local_ek(j,i)
              end do
        end do
c
      case( 666 )
        do j = 1, span
!DIR$ VECTOR ALIGNED
              do i = 1, 666
                    ek(i,j) = local_ek(j,i)
              end do
        end do
c
      case( 1830 )
        do j = 1, span
!DIR$ VECTOR ALIGNED
              do i = 1, 1830
                    ek(i,j) = local_ek(j,i)
              end do
        end do
c
      case default
        do j = 1, span
!DIR$ VECTOR ALIGNED
              do i = 1, nrow_ek
                    ek(i,j) = local_ek(j,i)
              end do
        end do
      end select
c
c
c
c                  time 5.16 secs
c
c      do i = 1, 1830
c            do j = 1, span
c                  ek(i,j) = local_ek(j,i)
c            end do
c      end do

      return
      end
c
c     ****************************************************************
c     *                                                              *
c     *                   subroutine rktstf_zero_vec                 *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 6/8/2016 rhd               *
c     *                                                              *
c     ****************************************************************
c
      subroutine rktstf_zero_vec( vec, nterms )
      implicit none
c
      integer :: nterms
      double precision :: vec(nterms), zero
      data zero / 0.0d00 /
c
!DIR$ VECTOR ALIGNED
      vec = zero
c
      return
      end
c     ****************************************************************
c     *                                                              *
c     *                      subroutine zero_vol                     *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 09/5/2017 rhd              *
c     *                                   meant to be inlined        *
c     *                                                              *
c     ****************************************************************
c
      subroutine rktstf_zero_vol ( vol, volume, span, mxvl )
      implicit none
      integer :: span, mxvl
      double precision  :: vol(mxvl,8,3), volume(span)
      double precision, parameter :: zero = 0.0d0
      vol = zero
      volume = zero
      return
      end


      REAL FUNCTION sdot(n,sx,incx,sy,incy)
      REAL sx(1),sy(1),stemp
      INTEGER i,incx,incy,ix,iy,m,mp1,n

      stemp = 0.0E0
      sdot = 0.0E0
      IF (n.LE.0) RETURN
      IF (incx.EQ.1 .AND. incy.EQ.1) GO TO 20
      ix = 1
      iy = 1
      IF (incx.LT.0) ix = (-n+1)*incx + 1
      IF (incy.LT.0) iy = (-n+1)*incy + 1
      DO 10 i = 1,n
          stemp = stemp + sx(ix)*sy(iy)
          ix = ix + incx
          iy = iy + incy
   10 CONTINUE
      sdot = stemp
      RETURN

   20 m = mod(n,5)
      IF (m.EQ.0) GO TO 40
      DO 30 i = 1,m
          stemp = stemp + sx(i)*sy(i)
   30 CONTINUE
      IF (n.LT.5) GO TO 60
   40 mp1 = m + 1
      DO 50 i = mp1,n,5
          stemp = stemp + sx(i)*sy(i) + sx(i+1)*sy(i+1) +
     +            sx(i+2)*sy(i+2) + sx(i+3)*sy(i+3) + sx(i+4)*sy(i+4)
   50 CONTINUE
   60 sdot = stemp
      RETURN

      END


      subroutine prtsca(ctb,jflag,jsflag,mrmlra,mwtsp,narn1,narn2,
     $ nbasp,nbaspd,nbt,nbtmax,nelect,nhydr,nhydx,noutpt,no2gaq,
     $ nstmax,qrho,rho,uspec,wfh2o)
c
c     This subroutine computes and prints a table of the sensible
c     composition of the aqueous solution in terms of mass balance
c     totals for component (basis) species that generally correspond to
c     analyzable solutes. This set of basis species is generally not
c     identical to either the active basis set or the 'd' basis set,
c     apart from the fact that it doesn't include the solvent, water.
c
c     This subroutine is called by:
c
c       EQ3NR/scripx.f
c       EQ6/scripz.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       ctb    = array of molalities of the component (basis) species
c       qrho   = .true. if a solution density value is available
c       rho    = the density of the aqueous solution
c       uspec  = array of names of aqueous species
c
c     Principal output:
c
c       None
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nbtmax,nstmax
c
      integer noutpt
c
      integer jflag(nstmax),jsflag(nstmax),nbasp(nbtmax),nbaspd(nbtmax)
      integer narn1,narn2,nbt,nelect,nhydr,nhydx,no2gaq
c
      logical qrho
c
      character(len=48) uspec(nstmax)
c
      real(8) ctb(nbtmax),mwtsp(nstmax)
      real(8) mrmlra,rho,wfh2o
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer nb,ns1,ns2
c
      real(8) ctbh,ctboh,molrx,ppmv,ppmw
c
c-----------------------------------------------------------------------
c
      write (noutpt,1000)
 1000 format(/11x,'--- Sensible Composition of the',
     $ ' Aqueous Solution ---')
c
      if (qrho) then
c
c       Have density data, include mg/L and Molarity.
c
        write (noutpt,1010)
 1010   format(/3x,'Species',20x,'mg/L',7x,'mg/kg.sol',4x,
     $  'Molarity',5x,'Molality',/)
c
        do nb = 1,nbt
          ns1 = nbaspd(nb)
          ns2 = nbasp(nb)
          if (ns1.ge.narn1 .and. ns1.le.narn2) then
            if (jsflag(ns2).lt.2 .and. jflag(ns2).ne.30) then
              if (ns1.ne.narn1 .and. ns1.ne.nelect .and.
     $          ns1.ne.no2gaq) then
                if (ns1.eq.nhydr .or. ns1.eq.nhydx) then
                  if (ctb(nb) .ge. 0.) then
                    ppmw = 1000.*ctb(nb)*mwtsp(ns1)*wfh2o
                    ppmv = ppmw*rho
                    molrx = ctb(nb)*mrmlra
                    write (noutpt,1020) uspec(ns1),ppmv,ppmw,
     $              molrx,ctb(nb)
 1020               format(1x,a24,1x,1pe12.5,1x,1pe12.5,1x,1pe12.5,
     $              1x,1pe12.5)
                  elseif (ns1 .eq. nhydr) then
                    ctboh = -ctb(nb)
                    ppmw = 1000.*ctboh*mwtsp(nhydx)*wfh2o
                    ppmv = ppmw*rho
                    molrx = ctb(nb)*mrmlra
                    write (noutpt,1020) uspec(nhydx),ppmv,ppmw,
     $              molrx,ctboh
                  else
                    ctbh = -ctb(nb)
                    ppmw = 1000.*ctbh*mwtsp(nhydr)*wfh2o
                    ppmv = ppmw*rho
                    molrx = ctb(nb)*mrmlra
                    write (noutpt,1020) uspec(nhydr),ppmv,ppmw,
     $              molrx,ctbh
                  endif
                else
                  ppmw = 1000.*ctb(nb)*mwtsp(ns1)*wfh2o
                  ppmv = ppmw*rho
                  molrx = ctb(nb)*mrmlra
                  write (noutpt,1020) uspec(ns1),ppmv,ppmw,
     $            molrx,ctb(nb)
                endif
              endif
            endif
          endif
        enddo
      else
c
c       Have no density data, so do not include mg/L and Molarity.
c
        write (noutpt,1030)
 1030   format(/3x,'Species',18x,'mg/kg.sol',4x,'Molality',/)
c
        do nb = 1,nbt
          ns1 = nbaspd(nb)
          ns2 = nbasp(nb)
          if (ns1.ge.narn1 .and. ns1.le.narn2) then
            if (jsflag(ns2).lt.2 .and. jflag(ns2).ne.30) then
              if (ns1.ne.narn1 .and. ns1.ne.nelect .and.
     $          ns1.ne.no2gaq) then
                if (ns1.eq.nhydr .or. ns1.eq.nhydx) then
                  if (ctb(nb) .ge. 0.) then
                    ppmw = 1000.*ctb(nb)*mwtsp(ns1)*wfh2o
                    write (noutpt,1040) uspec(ns1),ppmw,ctb(nb)
 1040               format(1x,a24,1x,1pe12.5,1x,1pe12.5)
                  elseif (ns1 .eq. nhydr) then
                    ctboh = -ctb(nb)
                    ppmw = 1000.*ctboh*mwtsp(nhydx)*wfh2o
                    write (noutpt,1040) uspec(nhydx),ppmw,ctboh
                  else
                    ctbh = -ctb(nb)
                    ppmw = 1000.*ctbh*mwtsp(nhydr)*wfh2o
                    write (noutpt,1040) uspec(nhydr),ppmw,ctbh
                  endif
                else
                  ppmw = 1000.*ctb(nb)*mwtsp(ns1)*wfh2o
                  write (noutpt,1040) uspec(ns1),ppmw,ctb(nb)
                endif
              endif
            endif
          endif
        enddo
      endif
c
      write (noutpt,1050)
 1050 format(/3x,'The above data have physical significance, but',
     $ ' some may be',/3x,'inconsistent with certain analytical',
     $ ' methods or reporting schemes.',/)
c
      end