c___________________________________________________________________________
c     --- USER102: 2D 8-node magnetic solid (based on PLANE53)
c     --- uel102.f, element matrices, load vectors, and results
c     --- distribution R1.0, Lucas Brouwer 11/15/2018
c___________________________________________________________________________

      SUBROUTINE uel102 (elem,ielc,elmdat,eomask,nodes,locsvrL,kelreq,
     x kelfil,nr,xyz,u,kelout,zs,zass,damp,gstIF,zsc,zscnr,elvol,elmass,
     x center,elener,edindxL,lcerstL)

c   module subroutines
      USE quad2D, ONLY : set_dH
      USE quad2D, ONLY : set_quad
      USE quad2D, ONLY : set_HH

c   module variables (same for all elements - local coords => only set 1x)
      USE quad2D, ONLY : qw,nnode,edim,nq
      USE quad2D, ONLY : dH,HH,H

c   quench module - includes Jc fitting, current sharing etc.
      USE quench, ONLY : check_quench

c   inverse
      USE quad2D, ONLY : INVF2

c   material property module (includes roxie and others)

c     CU - CUDI,NIST,MATPRO
      USE matLIB, ONLY : rhocucudi
      USE matLIB, ONLY : rhocunist
      USE matLIB, ONLY : rhocunist_tref
      USE matLIB, ONLY : rhocumatpro

c   MFS module subroutines
      USE MFSdata, ONLY : initialize_MFS_EM
      USE MFSdata, ONLY :	initialize_var
      USE MFSdata, ONLY : count_ne

c   MFS module data (for transfer)
      USE MFSdata, ONLY : MFS

c___________________________________________________________________________
c     --- Include Decks
c       allows for use of ANSYS definitions and data on distibution
c       see .inc at \ANSYS Inc\v171\ansys\customize\include
c___________________________________________________________________________

c   standard
#include "impcom.inc"
#include "echprm.inc"
#include "elparm.inc"
#include "ansysdef.inc"
#include "seldcm.inc"

c   output etc.
#include "soptcm.inc"
#include "stepcm.inc"
#include "elecom.inc"
#include "elucom.inc"
#include "outpcm.inc"
#include "usvrcm.inc"

      EXTERNAL TrackBegin, TrackEnd
      EXTERNAL erhandler,pstev1,svgidx,svrget,rvrget,plast1,
     x subrd,subwrt,xyzup3,mreuse,creep1,swell1,
     x uep102,usereo,trrot,svrput,hvrput,svpidx,mctac,
     x matxv,vzero,vmove,viinit,vamb,tmpget,fluget,tranx3,
     x vapb1,vapb,eldwrtL,eldwrnL,nlpropcheckL

      EXTERNAL erinqr,wrinqr,elLenPsvrBuf
      integer  erinqr,wrinqr,elLenPsvrBuf
      EXTERNAL         dist3d
      DOUBLE PRECISION dist3d

c     EXTERNAL - ADDED BY LUCAS
      EXTERNAL edcget
      EXTERNAL edciqr
      integer edciqr
      EXTERNAL propev

c___________________________________________________________________________
c     --- Set Parameters
c___________________________________________________________________________

      DOUBLE PRECISION PI,MU0
      PARAMETER (PI=4.0D0*DATAN(1.0D0))
      PARAMETER (MU0=4.0D0*PI/1.0D7)

c___________________________________________________________________________
c     --- ANSYS Variables (in/out)
c___________________________________________________________________________

      INTEGER elem         ! element label number (index)
      INTEGER ielc(IELCSZ) ! array of element type characteristics
      INTEGER elmdat(10)   ! array of element data
      INTEGER eomask       ! bit pattern for element output (see outpcm)
      INTEGER nodes(nnode) ! array of element node numbers
      INTEGER kelreq(10)   ! matrix and load vector form requests
      INTEGER kelfil(10)   ! keys for incoming matrices/vectors
      INTEGER nr           ! matrix and load vector size (for elem)
      INTEGER kelout(10)   ! keys indicating created matrices and vectors

      LONGINT locsvrL      ! location of saved variables on .esav
      LONGINT edindxL(25)  ! element result data file indices
      LONGINT lcerstL      ! position on result file

      DOUBLE PRECISION xyz(6,nnode)  ! nodal coordinates (orig) and rot angle
      DOUBLE PRECISION u(nr,5)       ! element nodal solution values
      DOUBLE PRECISION zs(nr,nr)     ! stiffness/conductivity matrix    kelreq(1)
      DOUBLE PRECISION zass(nr,nr)   ! mass matrix                      kelreq(2)
      DOUBLE PRECISION damp(nr,nr)   ! damping/specific heat matrix     kelreq(3)
      DOUBLE PRECISION gstIF(nr,nr)  ! stress stiffness matrix          kelreq(4)
      DOUBLE PRECISION zsc(nr)       ! applied force vector           kelreq(5)
      DOUBLE PRECISION zscnr(nr)     ! n-r or imaginary force vector  kelreq(6)
c                                      or imaginary f vector          kelreq(7)
      DOUBLE PRECISION elvol         ! element volume
      DOUBLE PRECISION elflux        ! element linked flux
      DOUBLE PRECISION elmass        ! element mass
      DOUBLE PRECISION center(3)     ! centroid location
      DOUBLE PRECISION elener(5)     ! element energies

c___________________________________________________________________________
c     --- Local Variables
c___________________________________________________________________________

c     submatrices for stIFfness and damping (8x8 -> are THEN padded into full matrices)
      DOUBLE PRECISION Kaa(8,8),Kai(8,8),Kei(8,8),Kee(8,8)
      DOUBLE PRECISION Caa(8,8),Cea(8,8)

c     shape function matrix form operations (to avoid repeated generation when used for multiple matrices)
      DOUBLE PRECISION curlcurl(8,8),NtN(8,8),Npat(8,8)
      DOUBLE PRECISION djac

c     non-linear solution (NR-OPT)
      DOUBLE PRECISION ui(nr)

c     extracted Az from full solu vector
      DOUBLE PRECISION uB(8,1)       ! element nodal solution values
      DOUBLE PRECISION udBdt(8,1)    ! time deriv of element nodal solution values

c     first time -> to set local elem shape functions and their deriv
      Logical ftime
      DATA ftime/.true./
      SAVE ftime

c     loop counters, permute, etc.
      INTEGER i,j,k,l
      INTEGER perm(4)

c     real constant vector
      DOUBLE PRECISION rvr(18)
      DOUBLE PRECISION Sc,Nc,fcond,fsc,dirz
      DOUBLE PRECISION Lc,Li,RRR,Lpp,feff
      DOUBLE PRECISION crat

c     area fractions, scaling factor
      DOUBLE PRECISION f1,f2,f3
      DOUBLE PRECISION scl

c     saved variable vector
      DOUBLE PRECISION msvr(3)

c     MFS field transfer position
      INTEGER ERpos

c     quench properties
      INTEGER qflag
      DOUBLE PRECISION Bev
      DOUBLE PRECISION I0,Je,Jcw,Jc
      DOUBLE PRECISION IfCu,scIfCu
      DOUBLE PRECISION Jc0,Tc0,Bc0,ap,p
      DOUBLE PRECISION Jstemp(3)

c     IFCC properties
      DOUBLE PRECISION tau,tauMult,Ctau
      DOUBLE PRECISION Mx,My

c     element matrices (set each time)
      DOUBLE PRECISION xyz2D(edim,nnode)
      DOUBLE PRECISION dHL(nnode,edim),HL(nnode),dN(nnode,edim)
      DOUBLE PRECISION curldN(edim,nnode),HL2(nnode,1)
      DOUBLE PRECISION ijac(edim,edim),jac(edim,edim)

c     element output
      DOUBLE PRECISION Bm(edim,nq),Bout(3*nq),Bx(nq,1),By(nq,1)
      DOUBLE PRECISION Hout(3*nq)
      DOUBLE PRECISION dBdt(edim,nq)
      DOUBLE PRECISION JHtau,JHres
      DOUBLE PRECISION JHcon
      DOUBLE PRECISION JHeat(1)
      DOUBLE PRECISION EGeo(11)
      DOUBLE PRECISION Nmisc(30),Smisc(5)
      DOUBLE PRECISION NmiscCH(18)
      DOUBLE PRECISION Bmod
      DOUBLE PRECISION Sene

c     material properties
      DOUBLE PRECISION mu,rsvx,trefRRR
      DOUBLE PRECISION prop(2)
      DOUBLE PRECISION tempev
      DOUBLE PRECISION tref,tembeg(nnode)
      DOUBLE PRECISION tem(nnode),temEND(nnode)
      INTEGER lp(2)
      INTEGER mat,ireal,nrvr,nmmvr,nusvr,nfsvr
      INTEGER plopt,cropt,swopt,ktherm
      LONGINT keyplsL,keycrpL,keyswlL

c     je get
      DOUBLE PRECISION jbeg(4*nnode), jem(4*nnode),jend(4*nnode)
      INTEGER iex

c     saved variables
      INTEGER svindx(20)

c     variables for tracking, logging, etc.
      INTEGER er
      DATA er/600/
      SAVE er

c________________________________________________________________________________
c set pointers, get index, set element defaults
c________________________________________________________________________________

c     elmdat pointers defined in elparm
      mat = elmdat(EL_MAT)
      ireal = elmdat(EL_REAL)

c     ielc pointers defined in echprm and elccmt
      nrvr = ielc(NMTRLC)
      nusvr = ielc(NMUSVR)
      nfsvr = ielc(NMFSVR)

c     get the svr index vector
      CALL svgidx(locsvrL,svindx(1))

c     default ANSYS in/out var to zero
      elvol = 0.0d0
      elflux = 0.0d0
      elmass = 0.0d0
      center = 0.0d0
      elener = 0.0d0

c________________________________________________________________________________
c Initialize FEM / and MFS settings if needed
c________________________________________________________________________________

c     set up the gaussian points and then find the shape function gradient matrix in local coords (r,s,t): dN at gaussian point locations
c     this is the same for all elements so ONLY NEED TO CALL ONCE PER TYPE (i.e. indepedent of node location xyz)
c     if MFS is used with field transfer initialize the element counter etc. in the MFSdata module
      IF(ftime) THEN
        CALL set_quad()
        CALL set_dH()
        CALL set_HH()
c       initialize MFS module variables
        IF (ielc(KYOP2) .eq. 1) THEN
          CALL initialize_var()
        ENDIF
        ftime=.false.
      ELSE
      ENDIF

c________________________________________________________________________________
c Get Element Real Constants
c________________________________________________________________________________

c     get the element real constant data
      CALL rvrget (elem,ireal,ielc(1),nrvr,rvr(1))
			Sc = rvr(1)
			Nc = rvr(2)
      fcond = rvr(3)
      fsc = rvr(4)
      dirz = rvr(5)
      Lc = rvr(6)
      Li = rvr(7)
      RRR = rvr(8)
      Lpp = rvr(9)
      feff = rvr(10)
      Ctau = rvr(11)
      taumult = rvr(12)

c     set ratio of coil lengths
      crat = Li/Lc

c     Jc fit parameters
      Jc0 = rvr(13)
      Tc0 = rvr(14)
      Bc0 = rvr(15)
      ap = rvr(16)
      p = rvr(17)
      scIFCU = rvr(18)

c________________________________________________________________________________
c Get Saved Variables
c________________________________________________________________________________

c     get saved variables (Bev)
      CALL svrget (svindx(1),2,nfsvr,msvr(1))
      Bev = msvr(1)

c________________________________________________________________________________
c Add element to counter for MFS module if needed
c  -- then populate mapping vector the 2nd time called (after counting)
c  -- place the location in the shared data as the 2nd saved var (ERpos)
c  -- set single transfer values RRR,fcond,fsc
c________________________________________________________________________________

      IF (ielc(KYOP2) .eq. 1) THEN
        IF (kfstps.ne.1) THEN
          IF (msvr(3) .eq. -1) THEN
            CALL initialize_MFS_EM(elem,ERpos,RRR,fcond,fsc)
						msvr(2) = ERpos
            msvr(3) = 1
          ELSE
            ERpos = msvr(2)
          ENDIF
        ELSE
          CALL count_ne()
          er = er + 1
          msvr(3) = -1
        ENDIF
      ENDIF

c________________________________________________________________________________
c Compute current Bev for updated mat prop
c________________________________________________________________________________
c     compute (BeV) so the material properties can update within the time step
c     instead of using the field from the old timestep
      IF (kfstps.ne.1) THEN

        xyz2D = xyz(1:edim,:)
        Bmod = 0.0d0
        DO 22 i = 1,nq
          dHL = RESHAPE(dH(:,:,i),(/8,2/))
          jac = matmul(xyz2D,dhL)
          CALL INVF2(2,jac,ijac,djac)
          dN = matmul(dhL,ijac)
          DO 20 k = 1,nnode
						curldN(1,k) = dN(k,2)
						curldN(2,k) = -dN(k,1)
  20   	CONTINUE
          IF (ielc(KYOP1) .eq. 0) THEN
            Bm(:,i) = matmul(curldN,u(:,1))
          ELSEIF (ielc(KYOP1) .eq. 2) THEN
            DO 21 k = 1,8
						  uB(k,1) = u(1+(k-1)*3,1)
  21   	  CONTINUE
            Bm(:,i) = matmul(curldN,uB(:,1))
          ENDIF

c         Bmod = average of |B| at integration points f
          Bmod=Bmod+sqrt(Bm(1,i)*Bm(1,i)+Bm(2,i)*Bm(2,i))/nq

  22   CONTINUE
      ENDIF

c     set element field for mat prop etc. as ave at int. points
      Bev = Bmod

c________________________________________________________________________________
c Set a first temp, field, and current to avoid evalu prop with non-ini var
c________________________________________________________________________________
c     initial conditions and tref to this in normal ANSYS
c     in the future it would be good to adapt to this for an "IC" spec.
      IF (kfstps.eq.1) THEN
c       temp is handled with tref
        Bev = 5.0d0
        I0 = 20.0d0
      ENDIF

c________________________________________________________________________________
c Get Temperature
c________________________________________________________________________________
c     get tref
      CALL nlpropcheckL (mat,tref,keyplsL,plopt,keycrpL,cropt,
     x                  keyswlL,swopt)

c     get nodal temps
      CALL tmpget (elem,ielc(1),nnode,nodes(1),tref,nnode,tembeg(1),
     x     tem(1),temEND(1),ktherm)

c     set elem temp as average of nodal temps
      scl = 0.125d0
      tempev=scl*(tem(1)+tem(2)+tem(3)+tem(4))
     x     +scl*(tem(5)+tem(6)+tem(7)+tem(8))

c________________________________________________________________________________
c Get Material Properties
c    - choice is set by Keyopt(5)
c        KYOP5 = 0   ->  ANSYS table (temp only)
c        KYOP5 = 1   ->  NIST (temp,RRR,B)
c        KYOP5 = 2   ->  CUDI (temp,RRR,B)
c        KYOP5 = 3   ->  Matpro (temp,RRR,B)
c        KYOP5 = 4   ->  userCu.f (temp,RRR,B)  [user fortran function]
c         - need to include warnings when temp/field go out of mat prop range
c         - use err-handler for this and linear extrap prop. from there
c________________________________________________________________________________

c     default mu to mu0
        mu = MU0

      IF (ielc(KYOP5) .eq. 0) THEN
c       ANSYS input table
        lp(1) = 31  !murx=31
        lp(2) = 19  !rsvx = 19
        CALL propev(elem,mat,lp(1),tempev,prop(1),2)
        mu = prop(1)*MU0
        rsvx = prop(2)

      ELSEIF (ielc(KYOP5) .eq. 1) THEN
c       NIST
c       now define RRR from reference temp of 295
        trefRRR = 295.0d0
        rsvx = rhocunist_tref(tempev,RRR,Bev,trefRRR)

      ELSEIF (ielc(KYOP5) .eq. 2) THEN
c       CUDI
        rsvx = rhocucudi(tempev,RRR,Bev)

      ELSEIF (ielc(KYOP5) .eq. 3) THEN
c       Matpro
        rsvx = rhocumatpro(tempev,RRR,Bev)

      ELSEIF (ielc(KYOP5) .eq. 4) THEN
c       user defined fortran function -> can be compiled with dummy

      ELSE
c       add error for wrong setting of keyopt(8)
      ENDIF

c________________________________________________________________________________
c Set IFCC tau based on rho_cu(T,RRR,B), Lp, and feff
c________________________________________________________________________________
c    - choice is set by Keyopt(8)
c        KYOP8 = 0   ->  IFCC, tau calculated from mat
c        KYOP8 = 1   ->  No IFCC
c        KYOP8 = 2   ->  IFCC with fixed tau input as real const 11

      IF (ielc(KYOP8) .eq. 0) THEN
c       use Wilson, which differs from Lorenzo by a factor of two
        tau = MU0*Lpp*Lpp/(8d0*pi*pi*rsvx*Feff)
      ELSEIF (ielc(KYOP8) .eq. 1) THEN
        tau = 0.0d0
      ELSEIF (ielc(KYOP8) .eq. 2) THEN
        tau = Ctau
      ELSE
c       add error for wrong setting of keyopt(8)
      ENDIF

c_____________________________________________________________________________
c fractions of different regions
c  f1 = cond
c  f2 = SC
c  f3 = stabilizer
c________________________________________________________________________________
      f1 = 1d0-fcond
      f2 = fcond*fsc
      f3 = fcond*(1d0-fsc)

c________________________________________________________________________________
c find current densities	(Je,Jcw, etc.)
c________________________________________________________________________________

      IF (ielc(KYOP1) .eq. 0) THEN
c     Je loading k(1)=0

c     EDCGET is replaced with CRDGET to be compatabile with ANSYS 19.1
c			  CALL edciqr(elem,1)   !returns number of current densities stored for current element
c        IF(edciqr(elem,1).gt.0.25d0) THEN
c          CALL edcget(elem,Jstemp(1))
c          Je = Jstemp(3)

       CALL crdget(elem,ielc(1),8,nodes(1),8,jbeg(1),jem(1),jend(1),iex)

       IF(iex.gt.0.25d0) THEN
       scl = 0.125d0
       Je=scl*(jem(3)+jem(7)+jem(11)+jem(15))
     x     +scl*(jem(19)+jem(23)+jem(27)+jem(31))

       ELSE
          Je = 0.0d0
       ENDIF
        Jcw = abs(Je/f2)

      ELSEIF (ielc(KYOP1) .eq. 2) THEN
c     Circuit loading k(1)=2
        IF (kfstps.eq.0) THEN
          I0 = u(3,1)
        ELSE
c        here it would be better to add an user input IC
         I0 = 20.0d0
        ENDIF
        Jcw = abs(I0*Nc/(Sc*f2))
      ELSE
c     not conductor - or wrong selection of keyoption
        Jcw = 0.0d0
      ENDIF

c________________________________________________________________________________
c Find Quench State and Set Resistive Loss
c    - choice is set by Keyopt(7)
c        KYOP7 = 0   ->  check for quench with current sharing
c        KYOP7 = 1   ->  no current sharing or quenching
c        KYOP7 = 2   ->  force full quench
c        KYOP7 = 3   ->  check for quench with no current sharing -> abrupt transition
c________________________________________________________________________________

      IF (ielc(KYOP7) .eq. 0) THEN
c     check for quench and use current sharing to find % in stabilizer
c        quench flag: qflag
c         -1:  fully SC          (T<Tcs)
c          0:  current sharing   (Tcs<T<TcB0)
c         +1:  fully quenched    (T>TcB0)

c       find quench state based on Jc and choice of short-sample fit
        CALL check_quench(Jcw,tempev,Bev,Jc,qflag,IfCu,Jc0,Tc0,Bc0,ap,p)

      ELSEIF (ielc(KYOP7) .eq. 3) THEN
        CALL check_quench(Jcw,tempev,Bev,Jc,qflag,IfCu,Jc0,Tc0,Bc0,ap,p)
c       force abrupt transition (no current sharing)
        IF (IfCu .gt. 0.0d0) THEN
          IfCu = 1.0d0
          qflag = 1
        ENDIF

      ELSEIF (ielc(KYOP7) .eq. 1) THEN
c     force SC
        IfCu = 0.0d0
        qflag = -1

      ELSEIF (ielc(KYOP7) .eq. 2) THEN
c     force quenched
        IfCu = 1.0d0
        qflag = 1

      ELSE
c       add error for wrong setting of keyopt(7)

      ENDIF

c     scale by input real constant
      IfCu = IfCu*scIFCU

c     set resistive losses
      JHres = rsvx*fsc*fsc*Jcw*Jcw*IfCu*IfCu*fcond/(1.0d0-fsc)

c________________________________________________________________________________
c
c
c             BUILD ELEMENT MATRICES
c
c________________________________________________________________________________

      IF (ielc(KYOP1) .eq. 0) THEN
c___________________________________________________________________________
c       DOF = Az - Je driven cond -> keyopt(1)=0
c___________________________________________________________________________

c     shape the full 3D node location into 2D
      xyz2D = xyz(1:edim,:)

c      add a boolean to check if any matrix generation is desired -> otherwise skip integration look
c      amatreq = .false.

c initialize the matrices to be formed (before sum), and sEND back 0's for other matrices IF they are requested
      IF(kelreq(1).eq.1)THEN
        Kaa = 0.0d0
        Kai = 0.0d0
        Kee = 0.0d0
        Kei = 0.0d0
        zs = 0.0d0
        kelout(1) = 1
c        amatreq = .true.
      ENDIF
      IF(kelreq(2).eq.1)THEN
         zass = 0.0d0
c         kelout(2) = 1     removed because mreuse takes it out in plane53
c        amatreq = .true.
      ENDIF
      IF(kelreq(3).eq.1)THEN
         Caa = 0.0d0
         Cea = 0.0d0
         damp = 0.0d0
         kelout(3) = 1
c        amatreq = .true.
      ENDIF
      IF(kelreq(4).eq.1)THEN
         gstIF = 0.0d0
         kelout(4) = 1
c        amatreq = .true.
      ENDIF
      IF(kelreq(5).eq.1)THEN
         zsc = 0.0d0
         kelout(5) = 1
c        amatreq = .true.
      ENDIF
      IF(kelreq(6).eq.1)THEN
         zscnr = 0.0d0
         kelout(6) = 1
c        amatreq = .true.
      ENDIF

c ___________________________________________________________________________________________________________
c integration loop: do all at once to avoid duplication operations since many are shared (jac,curl-curl,etc.)
c ___________________________________________________________________________________________________________

      DO 801 i = 1,nq
          HL = H(:,i)
          HL2 = RESHAPE(H(:,i),(/8,1/))
          dHL = RESHAPE(dH(:,:,i),(/8,2/))
          jac = matmul(xyz2D,dHL)
          CALL INVF2(2,jac,ijac,djac)
          dN = matmul(dhL,ijac)

c         find element area
          elvol = elvol + qw(i)*djac

          DO 340 k = 1,nnode
						curldN(1,k) = dN(k,2)
						curldN(2,k) = -dN(k,1)
  340   	CONTINUE

c        set shape fucntion operations/forms that will be re-used by multiple matrices
          curlcurl = matmul(transpose(curldN),curldN)
          NtN = matmul(HL2,transpose(HL2))
          DO 345 k = 1,8
						DO 344 l = 1,8
							Npat(k,l) = HL2(l,1)
  344   	CONTINUE
  345   	CONTINUE

c __________________________________________________________________________________________________________
c IF requested, make stIFfness matrix by integrating with global coords using the four quadrature points
c __________________________________________________________________________________________________________
      IF(kelreq(1).eq.1) THEN
        Kaa = Kaa + qw(i)*djac*curlcurl/mu
      ENDIF

c __________________________________________________________________________________________________________
c IF requested, make load vector by integrating with global coords using the four quadrature points
c __________________________________________________________________________________________________________
      IF(kelreq(5).eq.1) THEN
        zsc = zsc + qw(i)*djac*Je*HL
      ENDIF

c __________________________________________________________________________________________________________
c IF requested, make damping matrix by integrating with global coords using the four quadrature points
c __________________________________________________________________________________________________________
      IF(kelreq(3).eq.1) THEN
        Caa = Caa + 2.0d0*tau*tauMult*fcond*qw(i)*djac*curlcurl/mu
      ENDIF

  801   	CONTINUE

      zs = Kaa
      damp = Caa

c __________________________________________________________________________________________________________
c Find Restoring Force (NROPT: NL-matrices)
c __________________________________________________________________________________________________________

c     restoring force
      IF(kelreq(6).eq.1) THEN
          ui = u(:,1)
          zscnr = matmul(zs,ui)
      ENDIF

      ELSEIF (ielc(KYOP1) .eq. 1) THEN
c___________________________________________________________________________
c       DOF = Az,volt - struct with eddy -> keyopt(1)=1
c___________________________________________________________________________
c      placeholder for future development

      ELSEIF (ielc(KYOP1) .eq. 2) THEN
c___________________________________________________________________________
c       DOF = Az,curr,emf - circuit coupled cond -> keyopt(1)=2
c___________________________________________________________________________

c     shape the full 3D node location into 2D
      xyz2D = xyz(1:edim,:)

c initialize the matrices to be formed (before sum), and send back 0's for other matrices IF they are requested
      IF(kelreq(1).eq.1)THEN
        Kaa = 0.0d0
        Kai = 0.0d0
        Kee = 0.0d0
        Kei = 0.0d0
        zs = 0.0d0
        kelout(1) = 1
      ENDIF
      IF(kelreq(2).eq.1)THEN
         zass = 0.0d0
c         kelout(2) = 1     removed because mreuse takes it out in plane53
      ENDIF
      IF(kelreq(3).eq.1)THEN
         Caa = 0.0d0
         Cea = 0.0d0
         damp = 0.0d0
         kelout(3) = 1
      ENDIF
      IF(kelreq(4).eq.1)THEN
         gstIF = 0.0d0
         kelout(4) = 1
      ENDIF
      IF(kelreq(5).eq.1)THEN
         zsc = 0.0d0
         kelout(5) = 1
      ENDIF
      IF(kelreq(6).eq.1)THEN
         zscnr = 0.0d0
         kelout(6) = 1
      ENDIF

c ___________________________________________________________________________________________________________
c integration loop: do all at once to avoid duplication operations since many are shared (jac,curl-curl,etc.)
c ___________________________________________________________________________________________________________

      DO 901 i = 1,nq
          HL = H(:,i)
          HL2 = RESHAPE(H(:,i),(/8,1/))
          dHL = RESHAPE(dH(:,:,i),(/8,2/))
          jac = matmul(xyz2D,dHL)
          CALL INVF2(2,jac,ijac,djac)
          dN = matmul(dhL,ijac)

c         find element area
          elvol = elvol + qw(i)*djac

          DO 440 k = 1,nnode
						curldN(1,k) = dN(k,2)
						curldN(2,k) = -dN(k,1)
  440   	CONTINUE

c        set shape fucntion operations/forms that will be re-used by multiple matrices
          curlcurl = matmul(transpose(curldN),curldN)
          NtN = matmul(HL2,transpose(HL2))
          DO 445 k = 1,8
						DO 444 l = 1,8
							Npat(k,l) = HL2(l,1)
  444   	CONTINUE
  445   	CONTINUE

c __________________________________________________________________________________________________________
c IF requested, make stIFfness matrix by integrating with global coords using the four quadrature points
c __________________________________________________________________________________________________________
      IF(kelreq(1).eq.1) THEN
        Kaa = Kaa + qw(i)*djac*curlcurl/mu
        Kai = Kai - dirz*Nc*qw(i)*djac*NtN/Sc
c       now add in the dIFferent lengths for inductance and resistance
        Kee = Kee - qw(i)*djac*Npat/(Sc*Lc)
        Kei = Kei + IFCU*Nc*Nc*rsvx*qw(i)*djac*Npat/(Sc*Sc*f3)
      ENDIF

c __________________________________________________________________________________________________________
c IF requested, make damping matrix by integrating with global coords using the four quadrature points
c __________________________________________________________________________________________________________
      IF(kelreq(3).eq.1) THEN
        Caa = Caa + 2.0d0*tau*tauMult*fcond*qw(i)*djac*curlcurl/mu
c       now add in the different lengths for inductance and resistance
        Cea = Cea + dirz*crat*Nc*qw(i)*djac*Npat/Sc
      ENDIF

  901   	CONTINUE

c __________________________________________________________________________________________________________
c build full matrices with padding etc
c __________________________________________________________________________________________________________

c     stiffness - expand damping matrix to 16x16 following plane53
      IF(kelreq(1).eq.1) THEN
				l = 1
        DO 449 i = 1,nr,3
				  j = 1
          DO 448 k = 1,nr,3
						zs(i,k) = Kaa(l,j)
						zs(i,k+2) = Kai(l,j)
						zs(i+1,k+1) = Kee(l,j)
						zs(i+1,k+2) = Kei(l,j)
						j = j+1
  448   	CONTINUE
						l = l+1
  449   CONTINUE

      ENDIF

c     damping - expand damping matrix to 16x16 following plane53
      IF(kelreq(3).eq.1) THEN
				l = 1
        DO 459 i = 1,nr,3
				  j = 1
          DO 458 k = 1,nr,3
						damp(i,k) = Caa(l,j)
						damp(i+1,k) = Cea(l,j)
						j = j+1
  458   	CONTINUE
						l = l+1
  459   CONTINUE
      ENDIF

c     the expansion can also be done using matrix multiplication
c       -> see FEM derivation reference manual
c       -> at some point should check if this improves speed

c __________________________________________________________________________________________________________
c Find Restoring Force (NROPT: NL-matrices)
c __________________________________________________________________________________________________________

c     restoring force
      IF(kelreq(6).eq.1) THEN
          ui = u(:,1)
          zscnr = matmul(zs,ui)
      ENDIF

      ENDIF

c __________________________________________________________________________________________________________
c If requested, calculate field at integration points
c __________________________________________________________________________________________________________
      elflux = 0.0d0
      IF (outkey.eq.1) THEN
        JHtau = 0.0d0
        Bmod = 0.0d0
        Sene = 0.0d0
        Mx = 0.0d0
        My = 0.0d0
        DO 852 i = 1,nq
          dHL = RESHAPE(dH(:,:,i),(/8,2/))
          jac = matmul(xyz2D,dhL)
          CALL INVF2(2,jac,ijac,djac)
          dN = matmul(dhL,ijac)

c         could include Nc,Sc,and dirz here or have them be added by user in /post1 (for now assume user will take care of it to calc inductance)
          elflux = elflux + qw(i)*djac*DOT_PRODUCT(H(:,i),u(:,1))

          DO 850 k = 1,nnode
						curldN(1,k) = dN(k,2)
						curldN(2,k) = -dN(k,1)
  850   	CONTINUE

          IF (ielc(KYOP1) .eq. 0) THEN
            Bm(:,i) = matmul(curldN,u(:,1))
						dBdt(:,i) = matmul(curldN,u(:,4))
          ELSEIF (ielc(KYOP1) .eq. 2) THEN

            DO 851 k = 1,8
						  uB(k,1) = u(1+(k-1)*3,1)
						  udBdt(k,1) = u(1+(k-1)*3,4)
  851   	  CONTINUE
            Bm(:,i) = matmul(curldN,uB(:,1))
            dBdt(:,i) = matmul(curldN,udBdt(:,1))

          ENDIF

c         Bmod = average of |B| at integration points f
          Bmod=Bmod+ sqrt(Bm(1,i)*Bm(1,i)+Bm(2,i)*Bm(2,i))/nq

c         find element stored energy integral - no M at this point
          Sene=Sene+.5d0*(Bm(1,i)*Bm(1,i)+Bm(2,i)*Bm(2,i))*qw(i)*djac/mu

c         IFCC heat generation and magnetization
          JHcon = 2.0d0*tau*tauMult*fcond/mu
          JHtau=JHtau+
     x     JHcon*(dBdt(1,i)*dBdt(1,i)+dBdt(2,i)*dBdt(2,i))/nq
          Mx = Mx - 2.0d0*tau*tauMult*fcond*dBdt(1,i)/(mu*nq)
          My = My - 2.0d0*tau*tauMult*fcond*dBdt(2,i)/(mu*nq)

  852   CONTINUE

      ENDIF

c ___________________________________________________________
c --- output to database
c ___________________________________________________________

      IF (outkey.eq.1) THEN

c       see EOMASK Definitions in outpcm.inc
        IF (btest(eomask,PDBE)) THEN

c         FIELD FLUXES
          IF (btest(eomask,PDBFLX)) THEN

c           EXTRAPOLATE FROM GAUSS POINTS TO CORNER NODES
 						Bx = matmul(HH,RESHAPE(Bm(1,:),(/4,1/)))
 						By = matmul(HH,RESHAPE(Bm(2,:),(/4,1/)))

c           reformat 2D to 3D (also matrix to a single vector)
 						perm = (/3,2,1,4/)   !permute to get guass points aligned with nodal connect. (swap 1->3)

						k=1
						DO 360 i = 1,nq
							Bout(k) = Bx(perm(i),1)    !Bx
							Bout(k+1) = By(perm(i),1)  !By
							Bout(k+2) = 0.0d0          !Bz

c             H = B/mu-M
							Hout(k) = Bx(perm(i),1)/mu - Mx     !Hx
							Hout(k+1) = By(perm(i),1)/mu - My   !Hy
							Hout(k+2) = 0.0d0                   !Hz

							k = k+3

  360   CONTINUE

						CALL eldwrtL (elem,EDEFX,lcerstL,edindxL(1),12,Bout(1))   !write B-flux to results file
c						CALL eldwrtL (elem,EDEFX,lcerstL,edindxL(1),24,Bout(1))   !write E-flux and B-flux to results file
						CALL eldwrtL (elem,5,lcerstL,edindxL(1),12,Hout(1))   !write H-flux to results file

          ENDIF

c         JOULE HEATING
          IF (btest(eomask,16)) THEN
            JHeat(1) = JHres + JHtau
						CALL eldwrtL (elem,16,lcerstL,edindxL(1),1,JHeat(1))
          ENDIF

c         NMISC Variables
          IF (btest(eomask,13)) THEN

						Nmisc = 0d0
			      Nmisc(1) = tempev
			      Nmisc(2) = Bev
						Nmisc(3) = I0
						Nmisc(4) = Jcw
						Nmisc(5) = Jc
						Nmisc(6) = qflag
						Nmisc(7) = Lc
						Nmisc(8) = Li
						Nmisc(9) = scIFCU
						Nmisc(10) = tau
						Nmisc(11) = JHres
						Nmisc(12) = JHtau
						Nmisc(13) = JHeat(1)
						Nmisc(14) = IfCu
						Nmisc(15) = RRR
						Nmisc(16) = fsc
						Nmisc(17) = fcond
						Nmisc(18) = rsvx
						Nmisc(19) = elem
						Nmisc(20) = elflux
						Nmisc(21) = Mx
						Nmisc(22) = My
c						Nmisc(23) = sqrt(dBdt(1,i)*dBdt(1,i)+dBdt(2,i)*dBdt(2,i))
            Nmisc(23) = 0.0d0
c           output Cern "rhoht"
c						Nmisc(24) = rsvx*IfCu*IfCu/(fcond*(1-fsc))
c           now remove IFCU
						Nmisc(24) = rsvx/(fcond*(1-fsc))
						Nmisc(25) = Jc0
						Nmisc(26) = Tc0
						Nmisc(27) = Bc0
						Nmisc(28) = ap
						Nmisc(29) = p
						Nmisc(30) = tauMult

c           also set saved variable now
						msvr(1) = Bmod

						CALL eldwrtL (elem,13,lcerstL,edindxL(1),30,Nmisc(1))   !write NMISC to res file

c -------------------------------------------------------------
c     Set shared data for thermal (Bev,qflag)
c       -- replaces binary file transfer with ~5x speed up
c -------------------------------------------------------------
            IF (ielc(KYOP2) .eq. 1) THEN
              MFS(1,ERpos) = Bev
              MFS(2,ERpos) = qflag
				      msvr(2) = ERpos
            ENDIF

       ENDIF

c         SMISC
          IF (btest(eomask,1)) THEN
            Smisc = Sene
            Smisc(1) = Je
						Smisc(2) = elflux
						CALL eldwrtL (elem,1,lcerstL,edindxL(1),5,Smisc(1))
          ENDIF

c         this seems to be output by default with the elvol and elener(5) variables
          elener(1) = Sene
          elener(6) = Sene

c         VOLU/AREA and Energy
          IF (btest(eomask,4)) THEN
						Egeo(1:5) = elener
						Egeo(1) = elvol
						CALL eldwrtL (elem,4,lcerstL,edindxL(1),11,Egeo(1))
          ENDIF

        ENDIF

      ENDIF

c -------------------------------------------------------------
c     Output saved variables and update pointers
c -------------------------------------------------------------

c      write out user saved element variables
      CALL svrput (svindx(1),2,nfsvr,msvr(1))

c     write out the svr index vector, which updates locsvrL pointer to next element
      CALL svpidx (locsvrL,svindx(1))

      END SUBROUTINE uel102


        subroutine abstra (idatm,wl,xmus,xmuv,uw,uo3,uwus,uo3us,
     a               idatmp,uwpl,uo3pl,uwusp,uo3usp,
     a      dtwava,dtozon,dtdica,dtoxyg,dtniox,dtmeth,dtmoca,
     a      utwava,utozon,utdica,utoxyg,utniox,utmeth,utmoca,
     a      ttwava,ttozon,ttdica,ttoxyg,ttniox,ttmeth,ttmoca )

c     transmittance calculation for ozone, water vapor,
c     carbon dioxyde and oxygen.

c     downward absorption water vapor dtwava
c     downward absorption ozone       dtozon
c     downward absorption carbon diox dtdica
c     downward absorption oxygen      dtoxyg
c     downward absorption nitrous oxi dtniox
c     downward absorption methane     dtmeth
c     downward absorption carbon mono dtmoca
c     upward absorption water vapor   utwava
c     upward absorption ozone         utozon
c     upward absorption carbon diox   utdica
c     upward absorption oxygen        utoxyg
c     upward   absorption nitrous oxi utniox
c     upward   absorption methane     utmeth
c     upward   absorption carbon mono utmoca
c     total(on the two paths ) absorption water vapor ttwava
c     total(on the two paths ) absorption ozone       ttozon
c     total(on the two paths ) absorption carbon diox ttdica
c     total(on the two paths ) absorption oxygen      ttoxyg
c     total    absorption nitrous oxi ttniox
c     total    absorption methane     ttmeth
c     total    absorption carbon mono ttmoca

      common /sixs_atm/ z(34),p(34),t(34),wh(34),wo(34)
      common /sixs_planesim/ zpl(34),ppl(34),tpl(34),whpl(34),wopl(34)
      real z,p,t,wh,wo
      real zpl,ppl,tpl,whpl,wopl
      integer iv,ivli(6),idatm,idatmp,i,id,idgaz,inu,k,n,nh
      real co3(102),tnu(10,3),
     a          a(8),rm(34),r2(34),r3(34),tp(34),rat(10)
      real rmpl(34),r2pl(34),r3pl(34),ratpl(10)
      real cch2o(15)
      real wl,xmus,xmuv,uw,uo3,uwus,uo3us,uwpl,uo3pl,uwusp,uo3usp
      real accu,ah2o,xh,dtcont,utcont,ttcont
      double precision ptest1,ptest
      real dtoxyg,dtniox,dtmeth,dtmoca,dtwava,dtozon,dtdica
      real utniox,utdica,utoxyg,utwava,utozon
      real utmeth,utmoca,ttwava,ttozon,ttdica,ttoxyg,ttniox,ttmeth
      real ttmoca
      real p0,g,t0,ds,te,roair,air,roco2,rmo2,rmo3,rmn2o,rmch4
      real rmco,v,te2,phi,psi,uu,u,up,uud,uut,uuu
      real ud,ut,upd,upt,udp,updp,udtp,updtp
      real ds2,uupl,upl,uppl
      real xi,xd,ako3,test1,test2,test3,udt,atest
      real updt,tt,y,utt,uptt,tn
C
      data(ivli(i),i=1,6)/2500,5060,7620,10180,12740,15300/
      data(co3(i),i=   1, 102)/
     a 4.50e-03, 8.00e-03, 1.07e-02, 1.10e-02, 1.27e-02, 1.71e-02,
     a 2.00e-02, 2.45e-02, 3.07e-02, 3.84e-02, 4.78e-02, 5.67e-02,
     a 6.54e-02, 7.62e-02, 9.15e-02, 1.00e-01, 1.09e-01, 1.20e-01,
     a 1.28e-01, 1.12e-01, 1.11e-01, 1.16e-01, 1.19e-01, 1.13e-01,
     a 1.03e-01, 9.24e-02, 8.28e-02, 7.57e-02, 7.07e-02, 6.58e-02,
     a 5.56e-02, 4.77e-02, 4.06e-02, 3.87e-02, 3.82e-02, 2.94e-02,
     a 2.09e-02, 1.80e-02, 1.91e-02, 1.66e-02, 1.17e-02, 7.70e-03,
     a 6.10e-03, 8.50e-03, 6.10e-03, 3.70e-03, 3.20e-03, 3.10e-03,
     a 2.55e-03, 1.98e-03, 1.40e-03, 8.25e-04, 2.50e-04, 0.      ,
     a 0.      , 0.      , 5.65e-04, 2.04e-03, 7.35e-03, 2.03e-02,
     a 4.98e-02, 1.18e-01, 2.46e-01, 5.18e-01, 1.02e+00, 1.95e+00,
     a 3.79e+00, 6.65e+00, 1.24e+01, 2.20e+01, 3.67e+01, 5.95e+01,
     a 8.50e+01, 1.26e+02, 1.68e+02, 2.06e+02, 2.42e+02, 2.71e+02,
     a 2.91e+02, 3.02e+02, 3.03e+02, 2.94e+02, 2.77e+02, 2.54e+02,
     a 2.26e+02, 1.96e+02, 1.68e+02, 1.44e+02, 1.17e+02, 9.75e+01,
     a 7.65e+01, 6.04e+01, 4.62e+01, 3.46e+01, 2.52e+01, 2.00e+01,
     a 1.57e+01, 1.20e+01, 1.00e+01, 8.80e+00, 8.30e+00, 8.60e+00/

      DATA (CCH2O(I),I=1,15)/
     a 0.00,0.19,0.15,0.12,0.10,0.09,0.10,0.12,0.15,0.17,0.20,0.24,
     a 0.28,0.33,0.00/

      accu=1.E-10
      dtwava=1.
      utwava=1.
      ttwava=1.
      dtcont=1.
      utcont=1.
      ttcont=1.
      dtozon=1.
      utozon=1.
      ttozon=1.
      dtdica=1.
      utdica=1.
      ttdica=1.
      dtoxyg=1.
      utoxyg=1.
      ttoxyg=1.
      dtniox=1.
      utniox=1.
      ttniox=1.
      dtmeth=1.
      utmeth=1.
      ttmeth=1.
      dtmoca=1.
      utmoca=1.
      ttmoca=1.
      do 201 i=1,10
corig do 201 i=1,7
      rat(i)=1.
      tnu(i,1)=1.
      tnu(i,2)=1.
      tnu(i,3)=1.
  201 continue

      if (idatm.eq.0) return
      if((xmus.eq.0.).or.(xmuv.eq.0.)) goto 95

c     constants determination

      p0=1013.25
      g=98.1
      t0=250.

c     volumic mass in kilogrammes per m3

      ds=0.
      te=0.
      roair=0.
      air=0.028964/0.0224
      roco2=0.044/0.0224
      rmo2=0.032/0.0224
      rmo3=0.048/0.0224
      rmn2o=0.044/0.0224
      rmch4=0.016/0.0224
      rmco =0.028/0.0224
      uwus=1.424
      uo3us=.344

      if(idatm.eq.8) goto 80
      goto 90
   80 rat(1)=uw/uwus
      rat(2)=1.
      rat(3)=1.
      rat(4)=uo3/uo3us
      rat(5)=1.
      rat(6)=1.
      rat(7)=1.
      rat(8)=uw/uwus
      rat(9)=uw/uwus
      rat(10)=uw/uwus

   90 v=1.0e+04/wl
      iv=v/5.
      iv=iv*5
      id=((iv-2500)/10)/256+1
      do 40 idgaz=1,7
c
c
      if (id.le.6) inu=(iv-ivli(id))/10+1
      goto(101,102,103,104,105,106),id
      goto 270
  106 if(idgaz.eq.1) call wava6(a,inu)
      if(idgaz.eq.2) goto 270
      if(idgaz.eq.3) call oxyg6(a,inu)
      if(idgaz.eq.4) goto 270
      if(idgaz.eq.5) call niox6(a,inu)
      if(idgaz.eq.6) call meth6(a,inu)
      if(idgaz.eq.7) call moca6(a,inu)
      goto 271
  105 if(idgaz.eq.1) call wava5(a,inu)
      if(idgaz.eq.2) goto 270
      if(idgaz.eq.3) call oxyg5(a,inu)
      if(idgaz.eq.4) goto 270
      if(idgaz.eq.5) call niox5(a,inu)
      if(idgaz.eq.6) call meth5(a,inu)
      if(idgaz.eq.7) call moca5(a,inu)
      goto 271
  104 if(idgaz.eq.1) call wava4(a,inu)
      if(idgaz.eq.2) goto 270
      if(idgaz.eq.3) call oxyg4(a,inu)
      if(idgaz.eq.4) goto 270
      if(idgaz.eq.5) call niox4(a,inu)
      if(idgaz.eq.6) call meth4(a,inu)
      if(idgaz.eq.7) call moca4(a,inu)
      goto 271
  103 if(idgaz.eq.1) call wava3(a,inu)
      if(idgaz.eq.2) call dica3(a,inu)
      if(idgaz.eq.3) call oxyg3(a,inu)
      if(idgaz.eq.4) goto 270
      if(idgaz.eq.5) call niox3(a,inu)
      if(idgaz.eq.6) call meth3(a,inu)
      if(idgaz.eq.7) call moca3(a,inu)
      goto 271
  102 if(idgaz.eq.1) call wava2(a,inu)
      if(idgaz.eq.2) call dica2(a,inu)
      if(idgaz.eq.3) goto 270
      if(idgaz.eq.4) goto 270
      if(idgaz.eq.5) call niox2(a,inu)
      if(idgaz.eq.6) call meth2(a,inu)
      if(idgaz.eq.7) call moca2(a,inu)
      goto 271
  101 if(idgaz.eq.1) call wava1(a,inu)
      if(idgaz.eq.2) call dica1(a,inu)
      if(idgaz.eq.3) goto 270
      if(idgaz.eq.4) call ozon1(a,inu)
      if(idgaz.eq.5) call niox1(a,inu)
      if(idgaz.eq.6) call meth1(a,inu)
      if(idgaz.eq.7) call moca1(a,inu)
      goto 271
  270 do 200 i=1,8
      a(i)=0.
  200 continue
  271 continue

c     mixing ratio calculation for each gaseous constituents
      do k=1,33
      roair=air*273.16*p(k)/(1013.25*t(k))
      tp(k)=(t(k)+t(k+1))/2.
      te=tp(k)-t0
      te2=te*te
      phi=exp(a(3)*te+a(4)*te2)
      psi=exp(a(5)*te+a(6)*te2)
      if(idgaz.eq.1) rm(k)=wh(k)/(roair*1000.)
      if(idgaz.eq.2) rm(k)=3.3e-04*roco2/air
      if(idgaz.eq.3) rm(k)=0.20947*rmo2/air
      if(idgaz.eq.4) rm(k)=wo(k)/(roair*1000.)
      if(idgaz.eq.5) rm(k)=310.e-09*rmn2o/air
      if(idgaz.eq.6) rm(k)=1.72e-06*rmch4/air
      if(idgaz.eq.7) rm(k)=1.00e-09*rmco /air
      r2(k)=rm(k)*phi
      r3(k)=rm(k)*psi
      enddo
c
      uu=0.
      u=0.
      up=0.
      uud=0.
      uut=0.
      uuu=0.
      ud=0.
      ut=0.
      upd=0.
      upt=0.
      udp=0.
      updp=0.
      udtp=0.
      updtp=0.

c     pressure scale integration sigma=p/p0

         do 50 k=2,33
         ds=(p(k-1)-p(k))/p(1)
         ds2=(p(k-1)*p(k-1)-p(k)*p(k))/(2.*p(1)*p0)
         uu=uu+((rm(k)+rm(k-1))/2.)*ds*rat(idgaz)
         u =u +((r2(k)+r2(k-1))/2.)*ds*rat(idgaz)
         up=up+((r3(k)+r3(k-1))/2.)*ds2*rat(idgaz)
   50    continue
         uu=uu*p(1)*100./g
         u=u*p(1)*100./g
         up=up*p(1)*100./g

         if(idgaz.eq.4) uu=1000.*uu/rmo3
         if(idgaz.eq.2) uu=1000.*uu/roco2
         if(idgaz.eq.5) uu=1000.*uu/rmn2o
         if(idgaz.eq.6) uu=1000.*uu/rmch4
         if(idgaz.eq.7) uu=1000.*uu/rmco

c     mixing ratio for plane calculation for each gaseous constituents
      if ((idatmp.eq.0).or.(idatmp.eq.4)) then
          uupl=uu
          upl=u
          uppl=up
          else
          do k=1,33
          roair=air*273.16*ppl(k)/(1013.25*tpl(k))
          tp(k)=(tpl(k)+tpl(k+1))/2.
          te=tp(k)-t0
          te2=te*te
          phi=exp(a(3)*te+a(4)*te2)
          psi=exp(a(5)*te+a(6)*te2)
          if(idgaz.eq.1) rmpl(k)=whpl(k)/(roair*1000.)
          if(idgaz.eq.2) rmpl(k)=3.3e-04*roco2/air
          if(idgaz.eq.3) rmpl(k)=0.20947*rmo2/air
          if(idgaz.eq.4) rmpl(k)=wopl(k)/(roair*1000.)
          if(idgaz.eq.5) rmpl(k)=310.e-09*rmn2o/air
          if(idgaz.eq.6) rmpl(k)=1.72e-06*rmch4/air
          if(idgaz.eq.7) rmpl(k)=1.00e-09*rmco /air
          r2pl(k)=rmpl(k)*phi
          r3pl(k)=rmpl(k)*psi
          enddo
c
          uupl=0.
          upl=0.
          uppl=0.
c update ratio plane
          do i=1,10
          ratpl(i)=1.
          enddo
          if (idatmp.eq.8) then
          ratpl(1)=uwpl/uwusp
          ratpl(2)=1.
          ratpl(3)=1.
          ratpl(4)=uo3pl/uo3usp
          ratpl(5)=1.
          ratpl(6)=1.
          ratpl(7)=1.
          ratpl(8)=uwpl/uwusp
          ratpl(9)=uwpl/uwusp
          ratpl(10)=uwpl/uwusp
          endif
c     pressure scale integration sigma=p/p0

c* all gases
         do k=2,33
         ds=(ppl(k-1)-ppl(k))/ppl(1)
         ds2=(ppl(k-1)*ppl(k-1)-ppl(k)*ppl(k))/(2.*ppl(1)*p0)
         uupl=uupl+((rmpl(k)+rmpl(k-1))/2.)*ds*ratpl(idgaz)
         upl =upl +((r2pl(k)+r2pl(k-1))/2.)*ds*ratpl(idgaz)
         uppl=uppl+((r3pl(k)+r3pl(k-1))/2.)*ds2*ratpl(idgaz)
         enddo
         uupl=uupl*ppl(1)*100./g
         upl=upl*ppl(1)*100./g
         uppl=uppl*ppl(1)*100./g

         if(idgaz.eq.4) uupl=1000*uupl/rmo3
         if(idgaz.eq.2) uupl=1000*uupl/roco2
         if(idgaz.eq.5) uupl=1000*uupl/rmn2o
         if(idgaz.eq.6) uupl=1000*uupl/rmch4
         if(idgaz.eq.7) uupl=1000*uupl/rmco
c endif test idatm =0,4
      endif

c     downward path
      uud=uu/xmus
c     upward path
      uuu=uupl/xmuv
c     total(down+up) path
      uut=uu/xmus+uupl/xmuv

      if(idgaz.eq.1) goto 146
      if(idgaz.eq.2.and.iv.gt.9620) goto 147
      if(idgaz.eq.3.and.iv.gt.15920) goto 147
      if(idgaz.eq.4) goto 146
      goto 145
  146 xi=0.
      n=0
      xd=0.
      if(iv.lt.2350.or.iv.gt.3000) goto 148
      xi=(v-2350.)/50.+1.
      NH=XI+1.001
      XH=XI-FLOAT(NH)
      AH2O=CCH2O(NH)+XH*(CCH2O(NH)-CCH2O(NH-1))
      DTCONT=EXP(-AH2O*UUD)
      UTCONT=EXP(-AH2O*UUU)
      TTCONT=EXP(-AH2O*UUT)
  148 if (idgaz.eq.1) goto 145
      if(iv.lt.13000) goto 145
      if(iv.le.23400) goto 130
      if(iv.ge.27500) goto 135
      tnu(4,1)=1.
      tnu(4,2)=1.
      tnu(4,3)=1.
      goto 45
  130 xi=(v-13000.)/200.+1.
      goto 140
  135 xi=(v-27500.)/500.+57.
  140 n=xi+1.001
      xd=xi-float(n)
      ako3=co3(n)+xd*(co3(n)-co3(n-1))
      test1=ako3*uud
      test2=ako3*uuu
      test3=ako3*uut

c     exponential overflow test

      if(test1.gt.86.0) test1=86.0
      if(test2.gt.86.0) test2=86.0
      if(test3.gt.86.0) test3=86.0

      tnu(4,1)=exp(-test1)
      tnu(4,2)=exp(-test2)
      tnu(4,3)=exp(-test3)
      goto 40
  145 continue
      if(idgaz.eq.4.and.iv.gt.3020) goto 147
c
c     downward path
c
      ud=u/xmus
      upd=up/xmus
      udt=ud
      if(ud.eq.0.and.upd.eq.0.) udt=1.
      tn=a(2)*upd/(2*udt)
      atest=a(2)
      if (a(2).eq.0.and.a(1).eq.0.) atest=1.
      updt=upd
      if(ud.eq.0.and.upd.eq.0.) updt=1.
      tt=1+4*(a(1)/atest)*((ud*ud)/updt)
      y=-tn*(sqrt(tt)-1)
      if(idgaz.eq.1) y=-a(1)*ud/sqrt(1+(a(1)/atest)*(ud*ud/updt))
      tnu(idgaz,1)=exp(y)
c
c     upward path modified to take account for plane content
c
      udp=upl/xmuv
      updp=uppl/xmuv
      udtp=udp
      if(udp.eq.0.and.updp.eq.0.) udtp=1.
      tn=a(2)*updp/(2*udtp)
      atest=a(2)
      if (a(2).eq.0.and.a(1).eq.0.) atest=1.
      updtp=updp
      if(udp.eq.0.and.updp.eq.0.) updtp=1.
      tt=1+4*(a(1)/atest)*((udp*udp)/updtp)
      y=-tn*(sqrt(tt)-1)
      if(idgaz.eq.1) y=-a(1)*udp/sqrt(1+(a(1)/atest)*(udp*udp/updtp))
      tnu(idgaz,2)=exp(y)
c
c     total(down+up) path modified on the way up
c
      ut=u/xmus+upl/xmuv
      upt=up/xmus+uppl/xmuv
      utt=ut
      if(ut.eq.0.and.upt.eq.0.) utt=1.
      tn=a(2)*upt/(2*utt)
      uptt=upt
      if(ut.eq.0.and.upt.eq.0.) uptt=1.
      tt=1+4*(a(1)/atest)*((ut*ut)/uptt)
      y=-tn*(sqrt(tt)-1)
      if(idgaz.eq.1) y=-a(1)*ut/sqrt(1+(a(1)/atest)*(ut*ut/uptt))
      tnu(idgaz,3)=exp(y)
      goto 40
  147 tnu(idgaz,1)=1.
      tnu(idgaz,2)=1.
      tnu(idgaz,3)=1.
   40 continue
C
   45 ptest1=tnu(1,1)*dtcont
      ptest=ptest1
      if (ptest.gt.accu) then
         dtwava=ptest
         else
         dtwava=0.
         endif
      ptest1=tnu(1,2)*utcont
      ptest=ptest1
      if (ptest.gt.accu) then
         utwava=ptest
         else
         utwava=0.
         endif
      ptest1=tnu(1,3)*ttcont
      ptest=ptest1
      if (ptest.gt.accu) then
         ttwava=ptest
         else
         ttwava=0.
         endif
      dtdica=tnu(2,1)
      utdica=tnu(2,2)
      ttdica=tnu(2,3)
      dtoxyg=tnu(3,1)
      utoxyg=tnu(3,2)
      ttoxyg=tnu(3,3)
      dtozon=tnu(4,1)
      utozon=tnu(4,2)
      ttozon=tnu(4,3)
      dtniox=tnu(5,1)
      utniox=tnu(5,2)
      ttniox=tnu(5,3)
      dtmeth=tnu(6,1)
      utmeth=tnu(6,2)
      ttmeth=tnu(6,3)
      dtmoca=tnu(7,1)
      utmoca=tnu(7,2)
      ttmoca=tnu(7,3)
      if (idatmp.eq.0) then
         ttwava=dtwava
         utwava=1.
         ttdica=dtdica
         utdica=1.
         ttoxyg=dtoxyg
         utoxyg=1.
         ttozon=dtozon
         utozon=1.
         ttniox=dtniox
         utniox=1.
         ttmeth=dtmeth
         utmeth=1.
         ttmoca=dtmoca
         utmoca=1.
         endif
      return
   95 call print_error(
     s 'Error on zenithal angle ( near 90 deg )')
      return
      end


Subroutine pyresd
  Implicit Double Precision (D)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Save /lujets/
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  Common /ludat3/mdcy(500, 3), mdme(2000, 2), brat(2000), kfdp(2000, 5)
  Save /ludat3/
  Common /pysubs/msel, msub(200), kfin(2, -40:40), ckin(200)
  Save /pysubs/
  Common /pypars/mstp(200), parp(200), msti(200), pari(200)
  Save /pypars/
  Common /pyint1/mint(400), vint(400)
  Save /pyint1/
  Common /pyint2/iset(200), kfpr(200, 2), coef(200, 20), icol(40, 4, 2)
  Save /pyint2/
  Common /pyint4/widp(21:40, 0:40), wide(21:40, 0:40), wids(21:40, 3)
  Save /pyint4/
  Dimension iref(10, 6), kdcy(2), kfl1(2), kfl2(2), nsd(2), ilin(6), coup(6, 4), pk(6, 4), pkk(6, 6), cthe(2), phi(2), wdtp(0:40), wdte(0:40, 0:5)
  Complex fgk, ha(6, 6), hc(6, 6)
  fgk(i1, i2, i3, i4, i5, i6) = 4.*ha(i1, i3)*hc(i2, i6)*(ha(i1,i5)*hc(i1,i4)+ha(i3,i5)*hc(i3,i4))
  digk(dt, du) = -4.D0*d34*d56 + dt*(3.D0*dt+4.D0*du) + dt**2*(dt*du/(d34*d56)-2.D0*(1.D0/d34+1.D0/d56)*(dt+du)+2.D0*(d34/d56+d56/d34))
  djgk(dt, du) = 8.D0*(d34+d56)**2 - 8.D0*(d34+d56)*(dt+du) - 6.D0*dt*du - 2.D0*dt*du*(dt*du/(d34*d56)-2.D0*(1.D0/d34+1.D0/d56)*(dt+du)+2.D0*(d34/d56+d56/d34))
  isub = mint(1)
  sh = vint(44)
  iref(1, 5) = 0
  iref(1, 6) = 0
  If (iset(isub)==1 .Or. iset(isub)==3) Then
    iref(1, 1) = mint(84) + 2 + iset(isub)
    iref(1, 2) = 0
    iref(1, 3) = mint(83) + 6 + iset(isub)
    iref(1, 4) = 0
  Else If (iset(isub)==2 .Or. iset(isub)==4) Then
    iref(1, 1) = mint(84) + 1 + iset(isub)
    iref(1, 2) = mint(84) + 2 + iset(isub)
    iref(1, 3) = mint(83) + 5 + iset(isub)
    iref(1, 4) = mint(83) + 6 + iset(isub)
  End If
  np = 1
  ip = 0
  100 ip = ip + 1
  ninh = 0
  jtmax = 2
  If (ip==1 .And. (iset(isub)==1 .Or. iset(isub)==3)) jtmax = 1
  Do jt = 1, jtmax
    kdcy(jt) = 0
    kfl1(jt) = 0
    kfl2(jt) = 0
    nsd(jt) = iref(ip, jt)
    id = iref(ip, jt)
    If (id==0) Goto 140
    kfa = iabs(k(id,2))
    If (kfa<23 .Or. kfa>40) Goto 140
    If (mdcy(kfa,1)/=0) Then
      If (isub==1 .Or. isub==141) mint(61) = 1
      Call pywidt(kfa, p(id,5), wdtp, wdte)
      If (kchg(kfa,3)==0) Then
        ipm = 2
      Else
        ipm = (5+isign(1,k(id,2)))/2
      End If
      If (jtmax==1 .Or. iabs(k(iref(ip,1),2))/=iabs(k(iref(ip,2),2))) Then
        i12 = 4
      Else
        If (jt==1) i12 = int(4.5+rlu(0))
        i12 = 9 - i12
      End If
      rkfl = (wdte(0,1)+wdte(0,ipm)+wdte(0,i12))*rlu(0)
      Do i = 1, mdcy(kfa, 3)
        idc = i + mdcy(kfa, 2) - 1
        kfl1(jt) = kfdp(idc, 1)*isign(1, k(id,2))
        kfl2(jt) = kfdp(idc, 2)*isign(1, k(id,2))
        rkfl = rkfl - (wdte(i,1)+wdte(i,ipm)+wdte(i,i12))
        If (rkfl<=0.) Goto 130
      End Do
      130 Continue
    End If
    If ((kfa==23 .Or. kfa==24) .And. kfl1(jt)==0) ninh = ninh + 1
    If (kfl1(jt)==0) Goto 140
    kdcy(jt) = 2
    If (iabs(kfl1(jt))<=10 .Or. kfl1(jt)==21) kdcy(jt) = 1
    If ((iabs(kfl1(jt))>=23 .And. iabs(kfl1(jt))<=25) .Or. (iabs(kfl1(jt))==37)) kdcy(jt) = 3
    nsd(jt) = n
    pid5 = p(id, 5)
    If (kdcy(jt)==1) Then
      Call lu2ent(-(n+1), kfl1(jt), kfl2(jt), pid5)
    Else
      Call lu2ent(n+1, kfl1(jt), kfl2(jt), pid5)
    End If
    If (jtmax==1) Then
      cthe(jt) = vint(13) + (vint(33)-vint(13)+vint(34)-vint(14))*rlu(0)
      If (cthe(jt)>vint(33)) cthe(jt) = cthe(jt) + vint(14) - vint(33)
      phi(jt) = vint(24)
    Else
      cthe(jt) = 2.*rlu(0) - 1.
      phi(jt) = paru(2)*rlu(0)
    End If
  140 End Do
  If (mint(3)==1 .And. ip==1) Then
    mint(25) = kfl1(1)
    mint(26) = kfl2(1)
  End If
  If (jtmax==1 .And. kdcy(1)==0) Goto 530
  If (jtmax==2 .And. kdcy(1)==0 .And. kdcy(2)==0) Goto 530
  If (mstp(45)<=0 .Or. iref(ip,2)==0 .Or. ninh>=1) Goto 500
  If (k(iref(1,1),2)==25 .And. ip==1) Goto 500
  If (k(iref(1,1),2)==25 .And. kdcy(1)*kdcy(2)==0) Goto 500
  ilin(1) = mint(84) + 1
  If (k(mint(84)+1,2)>0) ilin(1) = mint(84) + 2
  If (k(ilin(1),2)==21) ilin(1) = 2*mint(84) + 3 - ilin(1)
  ilin(2) = 2*mint(84) + 3 - ilin(1)
  imin = 1
  If (iref(ip,5)==25) imin = 3
  imax = 2
  iord = 1
  If (k(iref(ip,1),2)==23) iord = 2
  If (k(iref(ip,1),2)==24 .And. k(iref(ip,2),2)==-24) iord = 2
  If (iabs(k(iref(ip,iord),2))==25) iord = 3 - iord
  If (kdcy(iord)==0) iord = 3 - iord
  Do jt = iord, 3 - iord, 3 - 2*iord
    If (kdcy(jt)==0) Then
      ilin(imax+1) = nsd(jt)
      imax = imax + 1
    Else If (k(nsd(jt)+1,2)>0) Then
      ilin(imax+1) = n + 2*jt - 1
      ilin(imax+2) = n + 2*jt
      imax = imax + 2
      k(n+2*jt-1, 2) = k(nsd(jt)+1, 2)
      k(n+2*jt, 2) = k(nsd(jt)+2, 2)
    Else
      ilin(imax+1) = n + 2*jt
      ilin(imax+2) = n + 2*jt - 1
      imax = imax + 2
      k(n+2*jt-1, 2) = k(nsd(jt)+1, 2)
      k(n+2*jt, 2) = k(nsd(jt)+2, 2)
    End If
  End Do
  xw = paru(102)
  Do i = imin, imax
    Do j = 1, 4
      coup(i, j) = 0.
    End Do
    kfa = iabs(k(ilin(i),2))
    If (kfa>20) Goto 410
    coup(i, 1) = luchge(kfa)/3.
    coup(i, 2) = (-1)**mod(kfa, 2)
    coup(i, 4) = -2.*coup(i, 1)*xw
    coup(i, 3) = coup(i, 2) + coup(i, 4)
  410 End Do
  sqmz = pmas(23, 1)**2
  gzmz = pmas(23, 1)*pmas(23, 2)
  sqmw = pmas(24, 1)**2
  gzmw = pmas(24, 1)*pmas(24, 2)
  sqmzp = pmas(32, 1)**2
  gzmzp = pmas(32, 1)*pmas(32, 2)
  420 Do i = n + 1, n + 4
    k(i, 1) = 1
    Do j = 1, 5
      p(i, j) = 0.
    End Do
  End Do
  Do jt = 1, jtmax
    If (kdcy(jt)==0) Goto 440
    id = iref(ip, jt)
    p(n+2*jt-1, 3) = 0.5*p(id, 5)
    p(n+2*jt-1, 4) = 0.5*p(id, 5)
    p(n+2*jt, 3) = -0.5*p(id, 5)
    p(n+2*jt, 4) = 0.5*p(id, 5)
    cthe(jt) = 2.*rlu(0) - 1.
    phi(jt) = paru(2)*rlu(0)
    Call ludbrb(n+2*jt-1, n+2*jt, acos(cthe(jt)), phi(jt), dble(p(id,1)/p(id,4)), dble(p(id,2)/p(id,4)), dble(p(id,3)/p(id,4)))
  440 End Do
  Do i = 1, imax
    k(n+4+i, 1) = 1
    p(n+4+i, 4) = sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+p(ilin(i),3)**2+p(ilin(i),5)**2)
    p(n+4+i, 5) = p(ilin(i), 5)
    Do j = 1, 3
      p(n+4+i, j) = p(ilin(i), j)
    End Do
  End Do
  therr = acos(2.*rlu(0)-1.)
  phirr = paru(2)*rlu(0)
  Call ludbrb(n+5, n+4+imax, therr, phirr, 0D0, 0D0, 0D0)
  Do i = 1, imax
    Do j = 1, 4
      pk(i, j) = p(n+4+i, j)
    End Do
  End Do
  If (isub==22 .Or. isub==23 .Or. isub==25) Then
    Do i1 = imin, imax - 1
      Do i2 = i1 + 1, imax
        ha(i1, i2) = sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+pk(i2,3))/(1E-20+pk(i1,1)**2+pk(i1,2)**2))*cmplx(pk(i1,1), pk(i1,2)) - sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/(1E-20+pk(i2,1)**2+pk(i2,2)**2))*cmplx(pk(i2,1), pk(i2,2))
        hc(i1, i2) = conjg(ha(i1,i2))
        If (i1<=2) ha(i1, i2) = cmplx(0., 1.)*ha(i1, i2)
        If (i1<=2) hc(i1, i2) = cmplx(0., 1.)*hc(i1, i2)
        ha(i2, i1) = -ha(i1, i2)
        hc(i2, i1) = -hc(i1, i2)
      End Do
    End Do
  End If
  Do i = 1, 2
    Do j = 1, 4
      pk(i, j) = -pk(i, j)
    End Do
  End Do
  Do i1 = imin, imax - 1
    Do i2 = i1 + 1, imax
      pkk(i1, i2) = 2.*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))
      pkk(i2, i1) = pkk(i1, i2)
    End Do
  End Do
  If (iref(ip,5)==25) Then
    wt = 16.*pkk(3, 5)*pkk(4, 6)
    If (ip==1) wtmax = sh**2
    If (ip>=2) wtmax = p(iref(ip,6), 5)**4
  Else If (isub==1) Then
    If (kfa/=37) Then
      ei = kchg(iabs(mint(15)), 1)/3.
      ai = sign(1., ei+0.1)
      vi = ai - 4.*ei*xw
      ef = kchg(kfa, 1)/3.
      af = sign(1., ef+0.1)
      vf = af - 4.*ef*xw
      gg = 1.
      gz = 1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2)
      zz = 1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)
      If (mstp(43)==1) Then
        gz = 0.
        zz = 0.
      Else If (mstp(43)==2) Then
        gg = 0.
        gz = 0.
      End If
      asym = 2.*(ei*ai*gz*ef*af+4.*vi*ai*zz*vf*af)/(ei**2*gg*ef**2+ei*vi*gz*ef*vf+(vi**2+ai**2)*zz*(vf**2+af**2))
      wt = 1. + asym*cthe(jt) + cthe(jt)**2
      wtmax = 2. + abs(asym)
    Else
      wt = 1. - cthe(jt)**2
      wtmax = 1.
    End If
  Else If (isub==2) Then
    wt = (1.+cthe(jt))**2
    wtmax = 4.
  Else If (isub==15 .Or. isub==19) Then
    wt = ((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*(pkk(1,3)**2+pkk(2,4)**2) + ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*(pkk(1,4)**2+pkk(2,3)**2)
    wtmax = (coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)
  Else If (isub==16 .Or. isub==20) Then
    wt = pkk(1, 3)**2 + pkk(2, 4)**2
    wtmax = (pkk(1,3)+pkk(1,4))**2 + (pkk(2,3)+pkk(2,4))**2
  Else If (isub==22) Then
    s34 = p(iref(ip,iord), 5)**2
    s56 = p(iref(ip,3-iord), 5)**2
    ti = pkk(1, 3) + pkk(1, 4) + s34
    ui = pkk(1, 5) + pkk(1, 6) + s56
    wt = coup(1, 3)**4*((coup(3,3)*coup(5,3)*abs(fgk(1,2,3,4,5,6)/ti+fgk(1,2,5,6,3,4)/ui))**2+(coup(3,4)*coup(5,3)*abs(fgk(1,2,4,3,5,6)/ti+fgk(1,2,5,6,4,3)/ui))**2+(coup(3,3)*coup(5,4)*abs(fgk(1,2,3,4,6,5)/ti+fgk(1,2,6,5,3,4)/ui))**2+(coup(3,4)*coup(5,4)*abs(fgk(1,2,4,3,6,5)/ti+fgk(1,2,6,5,4,3)/ui))**2) + coup(1, 4)**4*((coup(3,3)*coup(5,3)*abs(fgk(2,1,5,6,3,4)/ti+fgk(2,1,3,4,5,6)/ui))**2+(coup(3,4)*coup(5,3)*abs(fgk(2,1,6,5,3,4)/ti+fgk(2,1,3,4,6,5)/ui))**2+(coup(3,3)*coup(5,4)*abs(fgk(2,1,5,6,4,3)/ti+fgk(2,1,4,3,5,6)/ui))**2+(coup(3,4)*coup(5,4)*abs(fgk(2,1,6,5,4,3)/ti+fgk(2,1,4,3,6,5)/ui))**2)
    wtmax = 4.*s34*s56*(coup(1,3)**4+coup(1,4)**4)*(coup(3,3)**2+coup(3,4)**2)*(coup(5,3)**2+coup(5,4)**2)*4.*(ti/ui+ui/ti+2.*sh*(s34+s56)/(ti*ui)-s34*s56*(1./ti**2+1./ui**2))
  Else If (isub==23) Then
    d34 = dble(p(iref(ip,iord),5)**2)
    d56 = dble(p(iref(ip,3-iord),5)**2)
    dt = dble(pkk(1,3)+pkk(1,4)) + d34
    du = dble(pkk(1,5)+pkk(1,6)) + d56
    cawz = coup(2, 3)/sngl(dt) - 2.*(1.-xw)*coup(1, 2)/(sh-sqmw)
    cbwz = coup(1, 3)/sngl(du) + 2.*(1.-xw)*coup(1, 2)/(sh-sqmw)
    wt = coup(5, 3)**2*abs(cawz*fgk(1,2,3,4,5,6)+cbwz*fgk(1,2,5,6,3,4))**2 + coup(5, 4)**2*abs(cawz*fgk(1,2,3,4,6,5)+cbwz*fgk(1,2,6,5,3,4))**2
    wtmax = 4.*sngl(d34*d56)*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*sngl(digk(dt,du))+cbwz**2*sngl(digk(du,dt))+cawz*cbwz*sngl(djgk(dt,du)))
  Else If (isub==24) Then
    wt = ((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*pkk(1, 3)*pkk(2, 4) + ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*pkk(1, 4)*pkk(2, 3)
    wtmax = (coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
  Else If (isub==25) Then
    d34 = dble(p(iref(ip,iord),5)**2)
    d56 = dble(p(iref(ip,3-iord),5)**2)
    dt = dble(pkk(1,3)+pkk(1,4)) + d34
    du = dble(pkk(1,5)+pkk(1,6)) + d56
    cdww = (coup(1,3)*sqmz/(sh-sqmz)+coup(1,2))/sh
    caww = cdww + 0.5*(coup(1,2)+1.)/sngl(dt)
    cbww = cdww + 0.5*(coup(1,2)-1.)/sngl(du)
    ccww = coup(1, 4)*sqmz/(sh-sqmz)/sh
    wt = abs(caww*fgk(1,2,3,4,5,6)-cbww*fgk(1,2,5,6,3,4))**2 + ccww**2*abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))**2
    wtmax = 4.*sngl(d34*d56)*(caww**2*sngl(digk(dt,du))+cbww**2*sngl(digk(du,dt))-caww*cbww*sngl(djgk(dt,du))+ccww**2*sngl(digk(dt,du)+digk(du,dt)-djgk(dt,du)))
  Else If (isub==26) Then
    wt = pkk(1, 3)*pkk(2, 4)
    wtmax = (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
  Else If (isub==30) Then
    If (k(ilin(1),2)>0) wt = ((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*(pkk(1,4)**2+pkk(3,5)**2) + ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*(pkk(1,3)**2+pkk(4,5)**2)
    If (k(ilin(1),2)<0) wt = ((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*(pkk(1,3)**2+pkk(4,5)**2) + ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*(pkk(1,4)**2+pkk(3,5)**2)
    wtmax = (coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)
  Else If (isub==31) Then
    If (k(ilin(1),2)>0) wt = pkk(1, 4)**2 + pkk(3, 5)**2
    If (k(ilin(1),2)<0) wt = pkk(1, 3)**2 + pkk(4, 5)**2
    wtmax = (pkk(1,3)+pkk(1,4))**2 + (pkk(3,5)+pkk(4,5))**2
  Else If (isub==141) Then
    ei = kchg(iabs(mint(15)), 1)/3.
    ai = sign(1., ei+0.1)
    vi = ai - 4.*ei*xw
    api = sign(1., ei+0.1)
    vpi = api - 4.*ei*xw
    ef = kchg(kfa, 1)/3.
    af = sign(1., ef+0.1)
    vf = af - 4.*ef*xw
    apf = sign(1., ef+0.1)
    vpf = apf - 4.*ef*xw
    gg = 1.
    gz = 1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2)
    gzp = 1./(8.*xw*(1.-xw))*sh*(sh-sqmzp)/((sh-sqmzp)**2+gzmzp**2)
    zz = 1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)
    zzp = 2./(16.*xw*(1.-xw))**2*sh**2*((sh-sqmz)*(sh-sqmzp)+gzmz*gzmzp)/(((sh-sqmz)**2+gzmz**2)*((sh-sqmzp)**2+gzmzp**2))
    zpzp = 1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmzp)**2+gzmzp**2)
    If (mstp(44)==1) Then
      gz = 0.
      gzp = 0.
      zz = 0.
      zzp = 0.
      zpzp = 0.
    Else If (mstp(44)==2) Then
      gg = 0.
      gz = 0.
      gzp = 0.
      zzp = 0.
      zpzp = 0.
    Else If (mstp(44)==3) Then
      gg = 0.
      gz = 0.
      gzp = 0.
      zz = 0.
      zzp = 0.
    Else If (mstp(44)==4) Then
      gzp = 0.
      zzp = 0.
      zpzp = 0.
    Else If (mstp(44)==5) Then
      gz = 0.
      zz = 0.
      zzp = 0.
    Else If (mstp(44)==6) Then
      gg = 0.
      gz = 0.
      gzp = 0.
    End If
    asym = 2.*(ei*ai*gz*ef*af+ei*api*gzp*ef*apf+4.*vi*ai*zz*vf*af+(vi*api+vpi*ai)*zzp*(vf*apf+vpf*af)+4.*vpi*api*zpzp*vpf*apf)/(ei**2*gg*ef**2+ei*vi*gz*ef*vf+ei*vpi*gzp*ef*vpf+(vi**2+ai**2)*zz*(vf**2+af**2)+(vi*vpi+ai*api)*zzp*(vf*vpf+af*apf)+(vpi**2+api**2)*zpzp*(vpf**2+apf**2))
    wt = 1. + asym*cthe(jt) + cthe(jt)**2
    wtmax = 2. + abs(asym)
  Else
    wt = 1.
    wtmax = 1.
  End If
  If (wt<rlu(0)*wtmax) Goto 420
  500 Do jt = 1, jtmax
    If (kdcy(jt)==0) Goto 520
    id = iref(ip, jt)
    Call ludbrb(nsd(jt)+1, nsd(jt)+2, acos(cthe(jt)), phi(jt), dble(p(id,1)/p(id,4)), dble(p(id,2)/p(id,4)), dble(p(id,3)/p(id,4)))
    k(id, 1) = k(id, 1) + 10
    k(id, 4) = nsd(jt) + 1
    k(id, 5) = nsd(jt) + 2
    idoc = mint(83) + mint(4)
    Do i = nsd(jt) + 1, nsd(jt) + 2
      mint(4) = mint(4) + 1
      i1 = mint(83) + mint(4)
      k(i, 3) = i1
      k(i1, 1) = 21
      k(i1, 2) = k(i, 2)
      k(i1, 3) = iref(ip, jt+2)
      Do j = 1, 5
        p(i1, j) = p(i, j)
      End Do
    End Do
    If (jtmax==1) Then
      mint(7) = mint(83) + 6 + 2*iset(isub)
      mint(8) = mint(83) + 7 + 2*iset(isub)
    End If
    pid5 = p(id, 5)
    If (mstp(71)>=1 .And. kdcy(jt)==1) Call lushow(nsd(jt)+1, nsd(jt)+2, pid5)
    If (kdcy(jt)/=3) Goto 520
    np = np + 1
    iref(np, 1) = nsd(jt) + 1
    iref(np, 2) = nsd(jt) + 2
    iref(np, 3) = idoc + 1
    iref(np, 4) = idoc + 2
    iref(np, 5) = k(iref(ip,jt), 2)
    iref(np, 6) = iref(ip, jt)
  520 End Do
  530 If (ip<np) Goto 100
  Return
End Subroutine pyresd


      subroutine gdkm_calc(iflg)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Calculate areas and lengths for GDKM calcs
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 3.0
!D2
!D2 Initial implementation: ?, Programmer: George Zyvoloski
!D2 11-Nov-2009
!D2 $Log:   /pvcs.config/fehm90/src/inflo3.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:06   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:08:18   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.7 Sources and sinks
!D3 2.6   Provide Input/Output Data Files
!D3 3.0   INPUT AND OUTPUT REQUIREMENTS
!D3
!***********************************************************************
!D4
!D4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      use comai
      use combi
      use comci
      use comdi
      use comji
      use comdti
      use comki
      use davidi
      implicit none

      integer i,icode,iflg,neqp1,i1,i2,jj,kb,kc,ii,kb1,i3s,i4s,kks
      integer i3,i4,kk,idir,imodel,j,nsize,ngdkm_con,ic,iws,kbs
      integer jk,kbmodel,idp,kbm,kcm,jm,minkb,maxkb,i1s,i2s,jjs
      integer icw,i1_mem
      integer, allocatable :: istrw_gdkm(:)
      integer, allocatable :: idum(:)
      integer, allocatable :: nelm_temp(:)
      integer, allocatable :: nconi(:)
      integer, allocatable :: nneigh(:,:)
      real*8,  allocatable :: vf_gdpm(:,:)
      real*8,  allocatable :: sxdum(:)
      real*8,  allocatable :: sx_gdkm(:,:)
      real*8,  allocatable :: sx_dum(:,:)
      real*8 area_mult,areat,sx2c,dis,dis2,cosz,rlp_min
      real*8 dis2min,aream
      real*8 cord1,cord2,cord3,cord1j,cord2j,cord3j
      real*8 cord1jg,cord2jg,cord3jg
      real*8 fac_nop
      real*8 sx1_primary,vfrac,sx1_total,vol_frac,perm
      parameter (rlp_min = 1.d-2)
      parameter (ngdkm_con = 6)

      neqp1 = neq +1
      if(gdkm_flag.eq.0) return
      if(iflg.eq.1) then
c     calculate some areas and lengths for GDKM calculations
c     establish connectivity for gdkm calcs
c     need estimate for  size of nelm_gdkm
c     at this call nelm should be populated gdpm connectivity
         allocate (idum(neq))
         allocate (sxdum(neq))
         i1 = (neq-neq_primary)*ngdkm_con
         i2 = neq-neq_primary
         allocate (sx_gdkm(i2,27))
         allocate (nconi(i2))
         allocate (nneigh(i2,27))
         sx_gdkm = 0.0d0
         sxdum = 0.0d0
         idum = 0
         nconi = 0
         nneigh = 0
c     ic is a counter for forming the connectivity matrix
         ic = i2
c     calculate volume_fractions of all gdpm nodes
         allocate(vf_gdpm(neq_primary,maxgdpmlayers))
         do i = 1,neq_primary
            imodel= igdpm(i)
c     first gdpm node is given last connection of primary node
c     check this logic
            kb = nelm(nelm(i+1))
            if(imodel.ne.0) then
               sx1_primary = sx1(i)
               vfrac = vfrac_primary(imodel)
               sx1_total = sx1_primary/vfrac
               do jk = 1, ngdpm_layers(imodel)
                  vf_gdpm(i,jk) = sx1(kb+jk-1)/sx1_total
               enddo
            endif
         enddo
c     now finish calculation
c     this logic is only strictly valid for parallel fracture model
         do i = 1,neq_primary
            imodel= igdpm(i)
            if(imodel.ne.0) then
               cord1 = cord(i,1)
               cord2 = cord(i,2)
               cord3 = 0.0
               if(icnl.eq.0) then
                  cord3 = cord(i,3)
               endif
c     find areas of all connecting (primary) gridblocks
c     parts lt i and gt i
c     first lt i (if i2<i1 then no nodes lt)
               i1 = nelm(i)+1
               i2 = nelmdg(i)-1
               j = 0
               do jj = i1,i2
                  kb = nelm(jj)
                  i3 = nelmdg(kb)+1
                  i4 = nelm(kb+1)
                  do kk = i3,i4
                     kb1 = nelm(kk)
                     if(kb1.eq.i) then
                        iw = istrw(kk-neqp1)
                        go to 100
                     endif
                  enddo
 100              continue
                  j = j+1
                  cord1j = cord(kb,1)
                  cord2j = cord(kb,2)
                  cord3j = 0.0
                  if(icnl.eq.0) then
                     cord3j = cord(kb,3)
                  endif
                  sx2c=sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
                  dis = sqrt((cord1-cord1j)**2 + (cord2-cord2j)**2 +
     &                 (cord3-cord3j)**2)
                  it10(j) = kb
                  t1(j) = sx2c
               enddo
c     next gt i (but only primary nodes; hence the "-1"
               i1 = nelmdg(i)+1
               i2 = nelm(i+1)-1
               do jj = i1,i2
                  kb = nelm(jj)
                  iw = istrw(jj-neqp1)
                  j = j+1
                  cord1j = cord(kb,1)
                  cord2j = cord(kb,2)
                  cord3j = 0.0
                  if(icnl.eq.0) then
                     cord3j = cord(kb,3)
                  endif
                  sx2c=sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
                  dis = sqrt((cord1-cord1j)**2 + (cord2-cord2j)**2 +
     &                 (cord3-cord3j)**2)
                  it10(j) = kb
                  t1(j) = sx2c
               enddo
c     first find total volume of primary and secondary porosity of node i
               sx1_primary = sx1(i)
               vfrac = vfrac_primary(imodel)
               sx1_total = sx1_primary/vfrac
c     look at secondary porosity nodes of node i
c     examine connections to neighbors (idp 1st first gdpm or secondary node)
               idp = nelm(nelm(i+1))
               do jk = 1, ngdpm_layers(imodel)
c     ii is the secondary porosity node number
                  ii = idp +(jk-1)
                  maxkb = 0
                  minkb = neq
                  cord1 = cord(ii,1)
                  cord2 = cord(ii,2)
                  cord3 = 0.0
                  if(icnl.eq.0) then
                     cord3 = cord(ii,3)
                  endif
c     remember volume frac of secondary node
                  vol_frac = sx1(ii)/sx1_total
c     save all areas and nodes in secondary porosity node ii
                  idum(ii) = 1
c     neighbor nodes greater than ii
                  i1s = nelmdg(ii)+1
                  i2s = nelm(ii+1)
                  do jjs = i1s,i2s
                     kbs = nelm(jjs)
                     iws = istrw(jjs-neqp1)
                     sx2c=sx(iws,isox)+sx(iws,isoy)+sx(iws,isoz)
                     idum(kbs) = 1
                     sxdum(kbs) = sx2c
                  enddo
c     neighbor nodes less than ii
                  i1s = nelm(ii)+1
                  i2s = nelmdg(ii)-1
                  do jjs = i1s,i2s
                     kbs = nelm(jjs)
                     i3s = nelmdg(kbs)+1
                     i4s = nelm(kbs+1)
                     do kks = i3s,i4s
                        if(nelm(kks).eq.ii) then
                           iws = istrw(kks-neqp1)
                           sx2c=sx(iws,isox)+sx(iws,isoy)+sx(iws,isoz)
                           idum(kbs) = 1
                           sxdum(kbs) = sx2c
                           maxkb = max(kbs,maxkb)
                           minkb = min(kbs,minkb)
                           go to 50
                        endif
                     enddo
 50                  continue
                  enddo
c
c     at this point we have, for every primary gridblock, the primary connections
c     and the areas, these are in it10(j) and t1(j) respectively
c     we also have the
c
                  do jj = 1,j
c     loop to find other primary node connections (with gdpm nodes)
                     kb = it10(jj)
c     areat = t1(jj)  this is the A/d formulation
                     areat = t1(jj)
                     cord1j = cord(kb,1)
                     cord2j = cord(kb,2)
                     cord3j = 0.0
                     if(icnl.eq.0) then
                        cord3j = cord(kb,3)
                     endif
c     find node kb matrix nodes
                     kbmodel= igdpm(kb)
                     if(kbmodel.ne.0) then
c     identify first matrix node
                        kbm = nelm(nelm(kb+1))
                        dis2min = 1.d20
                        do jm = 1, ngdpm_layers(kbmodel)
c     note special numbering for gdpm nodes
                           kc =  kbm+jm-1
                           cord1jg = cord(kc,1)
                           cord2jg = cord(kc,2)
                           cord3jg = 0.0
                           if(icnl.eq.0) then
                              cord3jg = cord(kc,3)
                           endif
c     now find closest node kb gdpm node to i gdpm node
c     can work with square of distance
                           dis2 = (cord1-cord1jg)**2 +
     &                          (cord2-cord2jg)**2 + (cord3-cord3jg)**2
                           if(dis2.lt.dis2min) then
                              kcm = kc
                              dis2min = dis2
                              aream = areat
                           endif
                        enddo
                        maxkb = max(kcm,maxkb)
                        minkb = min(kcm,minkb)
                        idum(kcm) = idum(kcm) + 1
c     calculated area/dis term
                        sxdum(kcm) = aream
                     else
c     connect to primary node
                        idum(kb) = 1
                        dis = sqrt((cord1-cord1j)**2 + (cord2-cord2j)**2
     &                       + (cord3-cord3j)**2)
                        sxdum(kb) = areat
                     endif
                  enddo
c     add connection to secondary node (ii) associated with primary node i
                  idum(ii) = 1
                  maxkb = max(ii,maxkb)
                  minkb = min(ii,minkb)
c     adjust connectivity and area coefficients
                  do jj = minkb,maxkb
                     if(idum(jj).ne.0) then
                        nconi(ii-neq_primary) = nconi(ii-neq_primary) +1
                        nneigh(ii-neq_primary,nconi(ii-neq_primary)) =
     &                       jj
                        sx_gdkm(ii-neq_primary,nconi(ii-neq_primary)) =
     &                       sxdum(jj)
                        idum(jj) = 0
                        sxdum(jj) = 0.0
                     endif
                  enddo
c
               enddo
            endif
         enddo
      endif
c     insure connection symmetry
      do i = neq_primary+1, neq
         i1 = nconi(i-neq_primary)
         do jj = 1,i1
c     identify i-kb connection
            kb = nneigh(i-neq_primary,jj)
c     look for kb-i connection
            if(kb.gt.neq_primary.and.kb.ne.i) then
               i2 = nconi(kb-neq_primary)
               do kk = 1,i2
                  kc = nneigh(kb-neq_primary,kk)
                  if(kc.eq.i) then
c     connection found
                     go to 150
                  endif
               enddo
c     no connection found (add it)
               nconi(kb-neq_primary) = nconi(kb-neq_primary) + 1
               nneigh(kb-neq_primary,nconi(kb-neq_primary)) = i
               sx_gdkm(kb-neq_primary,nconi(kb-neq_primary)) = 1.d20
 150           continue
            endif
         enddo
      enddo
c     now all the connections are included
c     complete area terms (always choose smallest A/d)
      do i = neq_primary+1, neq
         i1 = nconi(i-neq_primary)
         do jj = 1,i1
c     identify i-kb connection
            kb = nneigh(i-neq_primary,jj)
c     look for kb-i connection
            areat = abs(sx_gdkm(i-neq_primary,jj))
            if(kb.gt.neq_primary.and.kb.ne.i) then
               i2 = nconi(kb-neq_primary)
               do kk = 1,i2
                  kc = nneigh(kb-neq_primary,kk)
                  if(kc.eq.i) then
c     connection found
                     aream = abs(sx_gdkm(kb-neq_primary,kk))
                     go to 250
                  endif
               enddo
c     error condition
               write (ierr,*) 'missing connection i = ', i, 'kb = ',kb
               write (ierr,*) 'stopping in gdkm_calc'
               stop
 250           continue
               aream = -min(aream,areat)
               sx_gdkm(kb-neq_primary,kk) = aream
               sx_gdkm(i-neq_primary,jj) = aream
            endif
         enddo
      enddo
c     now add up extra space required for nelm
      ic = 0
      do i = neq_primary+1, neq
         ic = ic + nconi(i-neq_primary)
      enddo
c     correct size for nelm is nsize + ic
      nsize = nelm(neq+1)
c     this is the gdpm count:right total nodes and one connection from secondary nodes
c     ic contains secodary node connection back to primary plus connections 2nd to 2nd
      i2 = nsize + ic
      allocate(nelm_temp(nsize))
      nelm_temp(1:nsize) = nelm(1:nsize)
      deallocate (nelm)
      allocate (nelm(i2))
      ic = neq+1
      nelm(1) = ic
      do i = 1,neq_primary
         i1 = nelm_temp(i)+1
         i2 = nelm_temp(i+1)
         do j = i1,i2
            nelm(j) = nelm_temp(j)
            ic = ic +1
         enddo
         nelm(i+1) = ic
      enddo
c
      do i =  neq_primary+1, neq
         do j = 1, nconi(i-neq_primary)
            ic = ic + 1
            kb = nneigh(i-neq_primary,j)
            nelm(ic) = kb
            if(kb.eq.i) nelmdg(i) = ic
         enddo
         nelm(i+1) = ic
      enddo
c     construct new coefficient file
c     first calculate the new size (icw)
c     adjust for symmetry and no diag
c
      icw = 0
      do i = 1, neq
         i1 = nelmdg(i)+1
         i2 = nelm(i+1)
         do j = i1,i2
            icw = icw+1
         enddo
      enddo
      nsize = nelm(neq+1)-(neq+1)
c
      allocate(istrw_gdkm(nsize))
      istrw_gdkm = 0
      if(isoy.eq.1) then
         allocate(sx_dum(icw,1))
         icw = 0
         do i = 1, neq_primary
            i1 = nelmdg(i)+1
            i2 = nelm(i+1)
            do jj = i1,i2
               iw = istrw(jj-neqp1)
               icw = icw+1
               istrw_gdkm(jj-(neq+1)) = icw
               if(iw.ne.0) then
                  sx2c = sx(iw,1)
                  sx_dum(icw,1) = sx2c
               else
                  sx_dum(icw,1) = 0.
               endif
            enddo
         enddo
      else
         allocate(sx_dum(icw,3))
         icw = 0
         do i = 1, neq_primary
            i1 = nelmdg(i)+1
            i2 = nelm(i+1)
            do jj = i1,i2
               iw = istrw(jj-neqp1)
               sx2c = sx(iw,1)
               icw = icw+1
               istrw_gdkm(jj-(neq+1)) = icw
               sx_dum(icw,1) = sx(iw,1)
               sx_dum(icw,2) = sx(iw,2)
               sx_dum(icw,3) = sx(iw,3)
            enddo
         enddo
      endif
      deallocate (sx)

c     fill in symmetric coefficient matrix
      deallocate(istrw)
      ic = icw
c     for connection with secondary nodes
c     insure that the newly calculated coefficients are used
c     so must search below the diagonal
      sxdum = 0.0d0
      do i = neq_primary+1, neq
         do j = 1,nconi(i-neq_primary)
            sxdum(nneigh(i-neq_primary,j)) = sx_gdkm(i-neq_primary,j)
         enddo
         i1 = nelmdg(i)+1
         i2 = nelm(i+1)
         do jj = i1,i2
            kb = nelm(jj)
            ic = ic +1
            istrw_gdkm(jj-neqp1) = ic
            if(isoy.eq.1) then
               sx_dum(ic,isox) = sxdum(kb)/3.
            else
               sx_dum(ic,isox) = sxdum(kb)
               sx_dum(ic,isoy) = 0.0
               sx_dum(ic,isoz) = 0.0
            endif
         enddo
c     adjust primary to secondary connection
c     primary node must be first in connectivity list for node i
         i1 = nelm(i)+1
         kb = nelm(i1)
c     secondary node is last in neighbor list for primary node
         kk = nelm(kb+1)
         iw = istrw_gdkm(kk-neqp1)
         if(isoy.eq.1) then
            sx_dum(iw,1) = sxdum(kb)/3.
         else
            sx_dum(iw,isox) = sxdum(kb)
            sx_dum(iw,isoy) = 0.0
            sx_dum(iw,isoz) = 0.0
         endif
      enddo
      allocate(istrw(nsize))
      istrw = istrw_gdkm
      deallocate(istrw_gdkm)
c
c     change definition of nr
      nr = ic + 1
c
      if(isoy.eq.1) then
         allocate(sx(nr,1))
         do j = 1, ic
            sx(j,1) = sx_dum(j,1)
         enddo
      else
         allocate(sx(nr,3))
         do j = 1, ic
            sx(j,1) = sx_dum(j,1)
            sx(j,2) = sx_dum(j,2)
            sx(j,3) = sx_dum(j,3)
         enddo
      endif
      if(isoy.eq.1) then
         sx(nr,1) = 0.0
      else
         sx(nr,1) = 0.0
         sx(nr,2) = 0.0
         sx(nr,3) = 0.0
      endif

      do i = 1,neq_primary
         imodel= igdpm(i)
c     first gdkm node is given last connection of primary node
         if(imodel.ne.0) then
            kb = nelm(nelm(i+1))
            corz(kb,1) = cord(i,1)
            corz(kb,2) = cord(i,2)
            corz(kb,3) = cord(i,3)
         endif
      enddo
      gdpm_flag = 0
      neq_gdkm = neq_primary
      neq_primary = neq
c     deallocate memory
      deallocate(idum,nconi,nneigh)
      deallocate(vf_gdpm,sxdum,sx_dum,sx_gdkm)
      if(allocated(vfrac_primary)) deallocate(vfrac_primary)
c     endif
c
      end


      SUBROUTINE FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
     *           LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI7501      BDS SECOND ORDER PACKING
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-08-06
C
C ABSTRACT: PERFORM SECONDARY PACKING ON GRID POINT DATA,
C   GENERATING ALL BDS INFORMATION.
C
C PROGRAM HISTORY LOG:
C   93-08-06  CAVANAUGH
C   93-12-15  CAVANAUGH   CORRECTED LOCATION OF START OF FIRST ORDER
C                         VALUES AND START OF SECOND ORDER VALUES TO
C                         REFLECT A BYTE LOCATION IN THE BDS INSTEAD
C                         OF AN OFFSET.
C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
C
C USAGE:    CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
C    *           LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE)
C   INPUT ARGUMENT LIST:
C     IWORK    - INTEGER SOURCE ARRAY
C     NPTS     - NUMBER OF POINTS IN IWORK
C     IBDSFL   - FLAGS
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IPFLD    - CONTAINS BDS FROM BYTE 12 ON
C     BDS11    - CONTAINS FIRST 11 BYTES FOR BDS
C     LEN      - NUMBER OF BYTES FROM 12 ON
C     LENBDS   - TOTAL LENGTH OF BDS
C
C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256
C
C$$$
      CHARACTER*1     BDS11(*),PDS(*)
C
      REAL            REFNCE
C
      INTEGER         ISCAL2,KWIDE
      INTEGER         LENBDS
      INTEGER         IPFLD(*)
      INTEGER         LEN,KBDS(22)
      INTEGER         IWORK(*)
C                        OCTET NUMBER IN SECTION, FIRST ORDER PACKING
C     INTEGER         KBDS(12)
C                        FLAGS
      INTEGER         IBDSFL(*)
C                        EXTENDED FLAGS
C     INTEGER         KBDS(14)
C                        OCTET NUMBER FOR SECOND ORDER PACKING
C     INTEGER         KBDS(15)
C                        NUMBER OF FIRST ORDER VALUES
C     INTEGER         KBDS(17)
C                        NUMBER OF SECOND ORDER PACKED VALUES
C     INTEGER         KBDS(19)
C                        WIDTH OF SECOND ORDER PACKING
      INTEGER         ISOWID(50000)
C                        SECONDARY BIT MAP
      INTEGER         ISOBMP(8200)
C                        FIRST ORDER PACKED VALUES
      INTEGER         IFOVAL(50000)
C                        SECOND ORDER PACKED VALUES
      INTEGER         ISOVAL(100000)
C
C     INTEGER         KBDS(11)
C                        BIT WIDTH TABLE
      INTEGER         IBITS(31)
C
      DATA            IBITS/1,3,7,15,31,63,127,255,511,1023,
     *                      2047,4095,8191,16383,32767,65535,131072,
     *                      262143,524287,1048575,2097151,4194303,
     *                      8388607,16777215,33554431,67108863,
     *                      134217727,268435455,536870911,
     *                      1073741823,2147483647/
C  ----------------------------------
C                       INITIALIZE ARRAYS
      DO 100 I = 1, 50000
          ISOWID(I)  = 0
          IFOVAL(I)  = 0
  100 CONTINUE
C
      DO 101 I = 1, 8200
          ISOBMP(I)  = 0
  101 CONTINUE
      DO 102 I = 1, 100000
          ISOVAL(I)  = 0
  102 CONTINUE
C                      INITIALIZE POINTERS
C                            SECONDARY BIT WIDTH POINTER
      IWDPTR  = 0
C                            SECONDARY BIT MAP POINTER
      IBMP2P  = 0
C                            FIRST ORDER VALUE POINTER
      IFOPTR  = 0
C                            BYTE POINTER TO START OF 1ST ORDER VALUES
      KBDS(12)  = 0
C                            BYTE POINTER TO START OF 2ND ORDER VALUES
      KBDS(15)  = 0
C                            TO CONTAIN NUMBER OF FIRST ORDER VALUES
      KBDS(17)  = 0
C                            TO CONTAIN NUMBER OF SECOND ORDER VALUES
      KBDS(19)  = 0
C                            SECOND ORDER PACKED VALUE POINTER
      ISOPTR  = 0
C  =======================================================
C
C                         DATA IS IN IWORK
C
      KBDS(11)  = KWIDE
C
C       DATA PACKING
C
      ITER    = 0
      INEXT   = 1
      ISTART  = 1
C  -----------------------------------------------------------
      KOUNT = 0
C     DO 1 I = 1, NPTS, 10
C         PRINT *,I,(IWORK(K),K=I, I+9)
C   1 CONTINUE
 2000 CONTINUE
      ITER  = ITER + 1
C     PRINT *,'NEXT ITERATION STARTS AT',ISTART
       IF (ISTART.GT.NPTS) THEN
           GO TO 4000
       ELSE IF (ISTART.EQ.NPTS) THEN
           KPTS    = 1
           MXDIFF  = 0
           GO TO 2200
       END IF
C
C                     LOOK FOR REPITITIONS OF A SINGLE VALUE
       CALL FI7502 (IWORK,ISTART,NPTS,ISAME)
       IF (ISAME.GE.15) THEN
           KOUNT = KOUNT + 1
C          PRINT *,'FI7501 - FOUND IDENTICAL SET OF ',ISAME
           MXDIFF  = 0
           KPTS    = ISAME
       ELSE
C
C                     LOOK FOR SETS OF VALUES IN TREND SELECTED RANGE
           CALL FI7513 (IWORK,ISTART,NPTS,NMAX,NMIN,INRNGE)
C          PRINT *,'ISTART  ',ISTART,' INRNGE',INRNGE,NMAX,NMIN
           IEND  = ISTART + INRNGE - 1
C          DO 2199 NM = ISTART, IEND, 10
C              PRINT *,'  ',(IWORK(NM+JK),JK=0,9)
C2199      CONTINUE
           MXDIFF  = NMAX - NMIN
           KPTS    = INRNGE
       END IF
 2200 CONTINUE
C     PRINT *,'                 RANGE ',MXDIFF,' MAX',NMAX,' MIN',NMIN
C                 INCREMENT NUMBER OF FIRST ORDER VALUES
      KBDS(17)  = KBDS(17) + 1
C                 ENTER FIRST ORDER VALUE
      IF (MXDIFF.GT.0) THEN
          DO 2220 LK = 0, KPTS-1
              IWORK(ISTART+LK)  = IWORK(ISTART+LK) - NMIN
 2220     CONTINUE
          CALL SBYTE (IFOVAL,NMIN,IFOPTR,KBDS(11))
      ELSE
          CALL SBYTE (IFOVAL,IWORK(ISTART),IFOPTR,KBDS(11))
      END IF
      IFOPTR  = IFOPTR + KBDS(11)
C                  PROCESS SECOND ORDER BIT WIDTH
      IF (MXDIFF.GT.0) THEN
          DO 2330 KWIDE = 1, 31
              IF (MXDIFF.LE.IBITS(KWIDE)) THEN
                  GO TO 2331
              END IF
 2330     CONTINUE
 2331     CONTINUE
      ELSE
          KWIDE  = 0
      END IF
      CALL SBYTE (ISOWID,KWIDE,IWDPTR,8)
      IWDPTR  = IWDPTR + 8
C         PRINT *,KWIDE,' IFOVAL=',NMIN,IWORK(ISTART),KPTS
C               IF KWIDE NE 0, SAVE SECOND ORDER VALUE
      IF (KWIDE.GT.0) THEN
          CALL SBYTES (ISOVAL,IWORK(ISTART),ISOPTR,KWIDE,0,KPTS)
          ISOPTR  = ISOPTR + KPTS * KWIDE
          KBDS(19)  = KBDS(19) + KPTS
C         PRINT *,'            SECOND ORDER VALUES'
C         PRINT *,(IWORK(ISTART+I),I=0,KPTS-1)
      END IF
C                 ADD TO SECOND ORDER BITMAP
      CALL SBYTE (ISOBMP,1,IBMP2P,1)
      IBMP2P  = IBMP2P + KPTS
      ISTART  = ISTART + KPTS
      GO TO 2000
C  --------------------------------------------------------------
 4000 CONTINUE
C     PRINT *,'THERE WERE ',ITER,' SECOND ORDER GROUPS'
C     PRINT *,'THERE WERE ',KOUNT,' STRINGS OF CONSTANTS'
C                 CONCANTENATE ALL FIELDS FOR BDS
C
C                   REMAINDER GOES INTO IPFLD
      IPTR  = 0
C                               BYTES 12-13
C                                          VALUE FOR N1
C                                          LEAVE SPACE FOR THIS
      IPTR   = IPTR + 16
C                               BYTE 14
C                                          EXTENDED FLAGS
      CALL SBYTE (IPFLD,IBDSFL(5),IPTR,1)
      IPTR  = IPTR + 1
      CALL SBYTE (IPFLD,IBDSFL(6),IPTR,1)
      IPTR  = IPTR + 1
      CALL SBYTE (IPFLD,IBDSFL(7),IPTR,1)
      IPTR  = IPTR + 1
      CALL SBYTE (IPFLD,IBDSFL(8),IPTR,1)
      IPTR  = IPTR + 1
      CALL SBYTE (IPFLD,IBDSFL(9),IPTR,1)
      IPTR  = IPTR + 1
      CALL SBYTE (IPFLD,IBDSFL(10),IPTR,1)
      IPTR  = IPTR + 1
      CALL SBYTE (IPFLD,IBDSFL(11),IPTR,1)
      IPTR  = IPTR + 1
      CALL SBYTE (IPFLD,IBDSFL(12),IPTR,1)
      IPTR  = IPTR + 1
C                               BYTES 15-16
C                 SKIP OVER VALUE  FOR N2
      IPTR  = IPTR + 16
C                               BYTES 17-18
C                                     P1
      CALL SBYTE (IPFLD,KBDS(17),IPTR,16)
      IPTR  = IPTR + 16
C                               BYTES 19-20
C                                   P2
      CALL SBYTE (IPFLD,KBDS(19),IPTR,16)
      IPTR  = IPTR + 16
C                               BYTE 21 - RESERVED LOCATION
      CALL SBYTE (IPFLD,0,IPTR,8)
      IPTR  = IPTR + 8
C                               BYTES 22 - ?
C                                      WIDTHS OF SECOND ORDER PACKING
      IX    = (IWDPTR + 32) / 32
      CALL SBYTES (IPFLD,ISOWID,IPTR,32,0,IX)
      IPTR  = IPTR + IWDPTR
C                                      SECONDARY BIT MAP
      IJ    = (IBMP2P + 32) / 32
      CALL SBYTES (IPFLD,ISOBMP,IPTR,32,0,IJ)
      IPTR  = IPTR + IBMP2P
      IF (MOD(IPTR,8).NE.0) THEN
          IPTR  = IPTR + 8 - MOD(IPTR,8)
      END IF
C                                         DETERMINE LOCATION FOR START
C                                         OF FIRST ORDER PACKED VALUES
      KBDS(12)  = IPTR / 8 + 12
C                                        STORE LOCATION
      CALL SBYTE (IPFLD,KBDS(12),0,16)
C                                     MOVE IN FIRST ORDER PACKED VALUES
      IPASS   = (IFOPTR + 32) / 32
      CALL SBYTES (IPFLD,IFOVAL,IPTR,32,0,IPASS)
      IPTR  = IPTR + IFOPTR
      IF (MOD(IPTR,8).NE.0) THEN
          IPTR  = IPTR + 8 - MOD(IPTR,8)
      END IF
C     PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR
C                DETERMINE LOCATION FOR START
C                     OF SECOND ORDER VALUES
      KBDS(15)  = IPTR / 8 + 12
C                                   SAVE LOCATION OF SECOND ORDER VALUES
      CALL SBYTE (IPFLD,KBDS(15),24,16)
C                  MOVE IN SECOND ORDER PACKED VALUES
      IX    = (ISOPTR + 32) / 32
      CALL SBYTES (IPFLD,ISOVAL,IPTR,32,0,IX)
      IPTR  = IPTR + ISOPTR
      NLEFT  = MOD(IPTR+88,16)
      IF (NLEFT.NE.0) THEN
          NLEFT  = 16 - NLEFT
          IPTR   = IPTR + NLEFT
      END IF
C                                COMPUTE LENGTH OF DATA PORTION
      LEN     = IPTR / 8
C                                    COMPUTE LENGTH OF BDS
      LENBDS  = LEN + 11
C  -----------------------------------
C                               BYTES 1-3
C                                   THIS FUNCTION COMPLETED BELOW
C                                   WHEN LENGTH OF BDS IS KNOWN
      CALL SBYTE (BDS11,LENBDS,0,24)
C                               BYTE  4
      CALL SBYTE (BDS11,IBDSFL(1),24,1)
      CALL SBYTE (BDS11,IBDSFL(2),25,1)
      CALL SBYTE (BDS11,IBDSFL(3),26,1)
      CALL SBYTE (BDS11,IBDSFL(4),27,1)
C                              ENTER NUMBER OF FILL BITS
      CALL SBYTE (BDS11,NLEFT,28,4)
C                               BYTE  5-6
      IF (ISCAL2.LT.0) THEN
          CALL SBYTE (BDS11,1,32,1)
          ISCAL2 = - ISCAL2
      ELSE
          CALL SBYTE (BDS11,0,32,1)
      END IF
      CALL SBYTE (BDS11,ISCAL2,33,15)
C
C$  FILL OCTET 7-10 WITH THE REFERENCE VALUE
C   CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
C   FLOATING POINT NUMBER
C                                        REFERENCE VALUE
C                                          FIRST TEST TO SEE IF
C                                          ON 32 OR 64 BIT COMPUTER
          CALL W3FI01(LW)
          IF (LW.EQ.4) THEN
              CALL W3FI76 (REFNCE,IEXP,IMANT,32)
          ELSE
              CALL W3FI76 (REFNCE,IEXP,IMANT,64)
          END IF
          CALL SBYTE (BDS11,IEXP,48,8)
          CALL SBYTE (BDS11,IMANT,56,24)
C
C                               BYTE  11
C
      CALL SBYTE (BDS11,KBDS(11),80,8)
C
      RETURN
      END


	SUBROUTINE VG_WSFC  ( cmn_data, sfcval, rdwrbuf, iret )
C************************************************************************
C* VG_WSFC								*
C*									*
C* This subroutine write the surface data to the output file.		*
C*									*
C* VG_WSFC ( CMN_DATA, SFCVAL, IRET )					*
C*									*
C* Input/Ouput parameters:                                              *
C*      CMN_DATA (*)    REAL            Common Data                     *
C*      SFCVAL(kxky,np) REAL            surface value of parms          *
C*
C* Output parameters:							*
C*	IRET		  INTEGER	Return code			*
C**									*
C* Log:									*
C* K. Brill/NMC      	06/92						*
C* K. Brill/NMC		08/92	Convert ln (q) to q			*
C* K. Brill/NMC		10/92	Send other surface parms to output file *
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C* R. Tian/SAIC		 4/05	Added GD_OPEN to get input/output file #*
C* T. Lee/SAIC		12/05	Initialized ighdr			*
C* G. Hull/SAIC         03/08   add cmn_data to remove Grid size limit  *
C************************************************************************
	INCLUDE		'vicmn.cmn'

	REAL            cmn_data (*), sfcval (kxky,np)
C* this is a temporary buffer used to read and then write out grids.
C
	REAL            rdwrbuf(kxky)

	INTEGER		ighdr ( LLGDHD ), lev (2)
	CHARACTER	ppp*12
	CHARACTER*20	time (2)
	LOGICAL		done
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
	CALL GD_OPEN ( gdcuri, wrtflg, 0, 0, igdfli,
     +                 adum1, adum2, mxgrd, iret )
	CALL GD_OPEN ( gdcuro, .true., 0, 0, igdflo,
     +                 adum1, adum2, mxgrd, iret )
C
C*	Determine packing information, and write the surface grids.
C
        DO ii = 1, LLGDHD
            ighdr ( ii ) = 0
        END DO
C
	lev (1) = 0
	lev (2) = -1
	DO ip = 1, np
	  IF ( lpmrds (ip) ) THEN
	    IF ( ip .eq. mstprm ) THEN
		ppp = 'SPFH'
		DO ij = 1, kxky
		    IF ( .not. ERMISS ( sfcval (ij,ip) ) )
     +			sfcval (ij,ip) =
     +                                   EXP ( sfcval (ij,ip) )
		END DO
	    ELSE
		ppp = parms (ip)
	    END IF

	    CALL VC_NBTS ( sfcval (1,ip), kxky, 4, nbits, ier )

	    CALL GD_WPGD ( igdflo, sfcval (1,ip),  kx, ky, ighdr,
     +			   gdttm, lev, igvco, ppp, .false.,
     +			   MDGGRB, nbits, ier )
	    IF ( ier .ne. 0 ) THEN
		CALL ER_WMSG ( 'GD', ier, ' ', irr )
	    END IF
	  END IF
	END DO
C
C*	Write the output vertical coordinate values on the surface.
C
	IF ( sfcovc ) THEN
	    CALL VC_NBTS ( cmn_data( ovcsfc_indx ), kxky, 4, nbits, ier )
	    CALL GD_WPGD ( igdflo, cmn_data( ovcsfc_indx ),
     +                     kx, ky, ighdr, gdttm, lev,
     +		           igvco, vcordo, .false., MDGGRB, nbits, ier )
	END IF
C
C*	Write out any other parameters with vertical coordinates
C*	listed in SFVCLT.
C*
	IF ( nsfvc .ne. 0 ) THEN
	    done = .false.
	    igrd = 1
	    DO WHILE ( .not. done )
C
C*	    	Get next grid header.
C
	    	CALL GD_GIDN ( igdfli, igrd, time, lev, jvc, ppp, ier )
	    	IF ( ier .eq. 0 .and. time (1) .eq. gdttm (1) ) THEN
		    DO i = 1, nsfvc
			IF ( isfvc (i) .eq. jvc ) THEN
C
C*			    Write out this data.
C
			    CALL VG_READ ( igdfli, sfvclt (i), lev (1),
     +					   ppp, sfcval,
     +					   cmn_data( vgread_buf_indx ),
     +                                     rdwrbuf, ier )
			    IF ( ier .eq. 0 ) THEN
	    			CALL VC_NBTS ( rdwrbuf, kxky,
     +						4, nbits, ier )
	    			CALL GD_WPGD ( igdflo, rdwrbuf,
     +						kx, ky,
     +						ighdr, gdttm, lev,
     +		           			jvc, ppp, .false.,
     +						MDGGRB, nbits, ier )
			    END IF
			END IF
		    END DO
	        ELSE
		    IF ( ier .ne. 0 ) done = .true.
	    	END IF
		igrd = igrd + 1
	    END DO
	END IF
C*
	RETURN
	END