      subroutine  dpdp3
!***********************************************************************
!  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.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  To load the double porosity/double permeability solution into the
CD1  solution matrix for a three degree of freedom system (air,water,
CD1  and heat).
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/dpdp3.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:52   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:02:58   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:08:30   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:23:20   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:59:48   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:40:50 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.5   Thu Feb 15 09:50:46 1996   zvd
CD2 Corrected purpose and requirements.
CD2
CD2    Rev 1.4   Wed Jan 10 11:07:20 1996   hend
CD2 Corrected ECD Number
CD2
CD2    Rev 1.3   Wed Jan 10 08:38:30 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.2   03/23/94 14:41:00   robinson
CD2 Additional cleanup of memory management
CD2
CD2    Rev 1.1   03/18/94 15:47:18   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:23:08   pvcs
CD2 original version in process of being certified
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3 2.3.2 Heat- and mass-transfer equations
CD3 2.4.9 Double-porosity/double-permeability formulation
CD3 2.5.2  Solve nonlinear equation set at each time step
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************
c 18-nov-92
c got rid of initialization of na and nb
c must be passed through
c 25-july-92
c started programming implementation of dpdp 3dof
c 1-13-92
c finished initial programming

      use combi
      use comci
      use comdi
      use comei
      use comfi
      use comgi
      use comhi
      use comji
      use davidi
      use comdti
      use comai
      use comflow
      implicit none

      integer i, ial, iau, icd, id, idg, idl, idum, isl, iz, jm, jml
      integer kb, kz, neighc, neq2, neqp1, nmat2avw
      real*8  acxy, acxyf, aexy, aexyf, alen, al0, al1, area, athkb
      real*8  axkb, axy, axyd, axyf
      real*8  cnli, cnlkb, cnvi, cnvkb, coef1, coefmx
      real*8  dclci, dclckb, dclei, dclekb, dcli, dclkb
      real*8  dcvci, dcvckb, dcvei, dcvekb, dcvi, dcvkb
      real*8  delci, delckb, delei, delekb, deli, delkb
      real*8  devci, devckb, devei, devekb, devi, devkb
      real*8  devmci, devmei, devmpi
      real*8  dfmlis, dfmlkbs, dfmvis, dfmvkbs
      real*8  dilci, dilckb, dili, dilei, dilekb, dilkb, dilpi, dilpkb
      real*8  divci, divckb, divei, divekb, divi, divkb, divpi, divpkb
      real*8  dist01
      real*8  dlaci, dlackb, dlaei, dlaekb, dlapi, dlapkb
      real*8  dlcci, dlcckb, dlci, dlcei, dlcekb, dlckb, dlcpi, dlcpkb
      real*8  dleci, dleckb, dleei, dleekb, dlei, dlekb, dlepi, dlepkb
      real*8  dlpi, dlpkb, dpvti
      real*8  dvaci, dvackb, dvaei, dvaekb, dvai, dvakb, dvapi, dvapkb
      real*8  dvam, dvame
      real*8  dvcci, dvcckb, dvcei, dvcekb, dvci, dvckb, dvcpi, dvcpkb
      real*8  dveci, dveckb, dveei, dveekb, dvei, dvekb, dvepi, dvepkb
      real*8  dvmckb, dvmekb, dvmpkb, dvpi, dvpkb
      real*8  heatc, enli, enlkb, envi, envkb, envmi, envmkb
      real*8  fid, fid1, fmkb, fmli, fmlkb, fmvi, fmvkb, frac0, frac1
      real*8  phii, phikb, pvii, pvikb, pvxy, pxy, pxyh, pxyi
      real*8  radi, radkb
      real*8  swi, sx2c, sx2t, sx4d, sx4h
      real*8  thxi, thxkb, thyi, thzi, ti, tot
      real*8  vcxy, vcxyf, vexy, vexyf, vxy, vxyd, vxyf
      parameter (coefmx=1000000000.0)

      neq2   =  neq+neq
      neqp1  =  neq+1
! Guessed at values nmat2avw, icd, fmkb
      nmat2avw = 0
      icd = 0
      fmkb = 1.0
      if(irdof.eq.0) then
         do  i=1,nmat(2)
            a(i+nmat(4))=0.
            a(i+nmat(5))=0.
            a(i+nmat(6))=0.
            a(i+nmat(10))=0.
            a(i+nmat(11))=0.
            a(i+nmat(12))=0.
            a(i+nmat(16))=0.
            a(i+nmat(17))=0.
            a(i+nmat(18))=0.
            a(i+nmat(19))=0.
            a(i+nmat(20))=0.
            a(i+nmat(21))=0.
            a(i+nmat(25))=0.
            a(i+nmat(26))=0.
            a(i+nmat(27))=0.
            a(i+nmat(31))=0.
            a(i+nmat(32))=0.
            a(i+nmat(33))=0.
         enddo
      else
c
c     zero out transfer terms
c
c     note that transfer terms are neq long ********************
c     this means that if we normalize with the 6dof system we will
c     miss some fill on the transfer terms
c
         do i=1,neq
            a(i+nmat(4))=0.
            a(i+nmat(5))=0.
            a(i+nmat(6))=0.
            a(i+nmat(10))=0.
            a(i+nmat(11))=0.
            a(i+nmat(12))=0.
            a(i+nmat(16))=0.
            a(i+nmat(17))=0.
            a(i+nmat(18))=0.
            a(i+nmat(19))=0.
            a(i+nmat(20))=0.
            a(i+nmat(21))=0.
            a(i+nmat(25))=0.
            a(i+nmat(26))=0.
            a(i+nmat(27))=0.
            a(i+nmat(31))=0.
            a(i+nmat(32))=0.
            a(i+nmat(33))=0.
         enddo
      endif
c
c     compute the fracture-matrix transfer terms
c
c     loop on nodes
      do id=1,neq
c     identify diagonal member
         idg =  nelmdg(id)
         idum =  idg-neqp1
c     identify matrix node
         i=id
         idl=id+neq
         kb=idl
         tot=sx1(id)+sx1(idl)
         frac0=sx1(id)/tot
         frac1=sx1(idl)/tot
         alen=apuv1(id)
         al0=frac0*alen
         al1=frac1*alen
c
c     determine contribution to node id
c
         dist01=0.5*(al0+al1)
         if(dist01.le.1.e-15) dist01=1.e-15
         area=tot/alen
         pvii=phi(i)
         phii=pvii-pcp(i)
         dpvti=dpcef(i)
         enli=enlf(i)
         deli=delf(i)
         delei=delef(i)
         envi=envf(i)
         devi=devf(i)
         devei=devef(i)
         cnli=cnlf(i)
         dcli=dclf(i)
         dclei=dclef(i)
         dclci=dclcf(i)
         cnvi=cnvf(i)
         dcvi=dcvf(i)
         dcvei=dcvef(i)
         dcvci=dcvcf(i)
         delci=delcf(i)
         devci=devcf(i)
         if(irlpt(irlp(i)).eq.7) then
c     add fracture-matrix factors(Sandia)
            fmvi=fmvf(i)
            dfmvis=dfmvf(i)
            fmvkb=fmvf(kb)
            dfmvkbs=dfmvf(kb)
            fmli=fmlf(i)
            dfmlis=dfmlf(i)
            fmlkb=fmlf(kb)
            dfmlkbs=dfmlf(kb)
         else
            fmvi=1.0
            dfmvis=0.0
            fmvkb=1.0
            dfmvkbs=0.0
            fmli=1.0
            dfmlis=0.0
            fmlkb=1.0
            dfmlkbs=0.0
         endif
         if(iupk.ne.0) then
c
c     even with iupk set pny contains the correct permeability
c     this will allow for harmonic weighting of the transfer perms
c
            dili=dil(i)/pny(i)*fmli
            divi=div(i)/pny(i)*fmvi
            dilpi=dilp(i)/pny(i)*fmli
            dilei=dile(i)/pny(i)*fmli + dil(i)/pny(i)*dfmlis
            divpi=divp(i)/pny(i)*fmvi
            divei=dive(i)/pny(i)*fmvi + div(i)/pny(i)*dfmvis
            dilkb=dil(kb)/pny(kb)*fmlkb
            divkb=div(kb)/pny(kb)*fmvkb
            dilpkb=dilp(kb)/pny(kb)*fmkb
            dilekb=dile(kb)/pny(kb)*fmlkb+ dil(kb)/pny(kb)*dfmlkbs
            divpkb=divp(kb)/pny(kb)*fmvkb
            divekb=dive(kb)/pny(kb)*fmvkb+ div(kb)/pny(kb)*dfmvkbs
            dilci=dilc(i)/pny(i)*fmli
            divci=divc(i)/pny(i)*fmvi
            dilckb=dilc(kb)/pny(kb)*fmlkb
            divckb=divc(kb)/pny(kb)*fmvkb
         else
            dili=dil(i)*fmli
            divi=div(i)*fmvi
            dilpi=dilp(i)*fmli
            dilei=dile(i)*fmli + dil(i)*dfmlis
            divpi=divp(i)*fmvi
            divei=dive(i)*fmvi + div(i)*dfmvis
            dilkb=dil(kb)*fmlkb
            divkb=div(kb)*fmvkb
            dilpkb=dilp(kb)*fmkb
            dilekb=dile(kb)*fmlkb+ dil(kb)*dfmlkbs
            divpkb=divp(kb)*fmvkb
            divekb=dive(kb)*fmvkb+ div(kb)*dfmvkbs
            dilci=dilc(i)*fmli
            divci=divc(i)*fmvi
            dilckb=dilc(kb)*fmlkb
            divckb=divc(kb)*fmvkb
         endif
         thxi=thx(i)
         thyi=thy(i)
         thzi=thz(i)
         ti=t(i)
         swi=s(i)
c
c     form constants for i>neq
c
         iz=i
         coef1=-area/dist01
         if(coef1.lt.-coefmx) coef1=coefmx
         if(iupk.ne.0) then
            axkb=max(pny(idl),zero_t)*pnx(idl)
         else
          if(idpdp.eq.1) then
            axkb =  max( pnx(idl),zero_t)
          else if(idpdp.eq.2) then
            axkb =  max( pny(idl),zero_t)
          else if(idpdp.eq.3) then
            axkb =  max( pnz(idl),zero_t)
          else
            axkb =  max( pnx(idl  ),pny(idl  ),
     *           pnz(idl  ),zero_t )
          endif
         endif
          if(idpdp.eq.1) then
            athkb =  max( thx(idl),zero_t)
          else if(idpdp.eq.2) then
            athkb =  max( thy(idl),zero_t)
          else if(idpdp.eq.3) then
            athkb =  max( thz(idl),zero_t)
          else
            athkb =  max( thx(idl  ),thy(idl  ),
     *        thz(idl  ),zero_t )
          endif
c
c     2-d geometry
c
         if(icnl.ne.0) then
            radi=cord(iz,3)
         else if(icnl.eq.0) then
            radi=1.0
         endif
         jm=1
         kb=idl
         kz=kb
         neighc=1
         perml(1)=axkb
         permv(1)=perml(1)
         radkb=radi
         sx2c=radkb*coef1
         thxkb=athkb
         sx2t=sx2c*thxkb
         pvikb=phi(kb)
         phikb=pvikb-pcp(kb)
         pxy=sx2c*perml(1)
         pvxy=sx2c*permv(1)
         pxyi=pxy*(phikb-phii)
         pxyh=pvxy*(pvikb-pvii)
         t1(neighc)=pxyi
         t2(neighc)=pxyh
         t3(neighc)=pxy
         t4(neighc)=pvxy
         t5(neighc)=sx2t
         t6(neighc)=0.0
         t7(neighc)=0.0
         t10(neighc)=sx2c
c
c     liquid phase calculations
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         pxyi=t1(neighc)
         sx4d=t6(neighc)
         axyd=pxyi+0.5*sx4d*(rolf(i)+rolf(kb))
     *        *(cord(kz,igrav)-cord(iz,igrav))
         t8(neighc)=axyd
c
c     determine upwind nodes and if liquid phase exists
c
         isl=0
         jm=1
         kb=idl
         kz=kb
         neighc=1
         fid=.5
         axyd=t8(neighc)
         if(axyd.lt.0.0) fid=dnwgt
         if(axyd.gt.0.0) fid=upwgt
         if(t3(neighc).lt.0.0) t9(neighc)=fid
         if(t3(neighc).gt.0.0) t9(neighc)=fid
         if(swi+s(kb).ne.0.0) isl=1
c
c     form equations
c
         if(isl.ne.0) then
            jm=1
            kb=idl
            kz=kb
            neighc=1
            axyd=t8(neighc)
            fid=t9(neighc)
            fid1=1.0-fid
            pxyi=t1(neighc)
            pxy=t3(neighc)
            sx4d=t6(neighc)
            enlkb=enlf(kb)
            cnlkb=cnlf(kb)
            dilpkb=dilp(kb)
            dilekb=dile(kb)
            dilckb=dilc(kb)
            delkb=delf(kb)
            delekb=delef(kb)
            delckb=delcf(kb)
            dclkb=dclf(kb)
            dclekb=dclef(kb)
            dclckb=dclcf(kb)
            dilkb=dil(kb)
            dlpi=-pxy+0.5*sx4d*dglp(i)*(cord(kz,igrav)-cord(iz,igrav))
            dlpkb=pxy+0.5*sx4d*dglp(kb)*(cord(kz,igrav)-cord(iz,igrav))
            dlei=pxy*dpvti+0.5*sx4d*dgle(i)*(cord(kz,igrav)-
     &           cord(iz,igrav))
            dlekb=-pxy*dpcef(kb)+0.5*sx4d*dgle(kb)
     *           *(cord(kz,igrav)-cord(iz,igrav))
            dlci=0.5*sx4d*dglc(i)*(cord(kz,igrav)-cord(iz,igrav))
            dlckb=0.5*sx4d*dglc(kb)*(cord(kz,igrav)-cord(iz,igrav))
            aexyf=(fid*dilkb*enlkb+fid1*dili*enli)
            axyf=(fid*dilkb+fid1*dili)
            acxyf=(fid*dilkb*cnlkb+fid1*dili*cnli)
            aexy=axyd*aexyf
            axy=axyd*axyf
            acxy=axyd*acxyf
            dlapi=dlpi*axyf+axyd*fid1*dilpi
            dlapkb=dlpkb*axyf+axyd*fid*dilpkb
            dlaei=dlei*axyf+axyd*fid1*dilei
            dlaekb=dlekb*axyf+axyd*fid*dilekb
            dlaci=dlci*axyf+axyd*fid1*dilci
            dlackb=dlckb*axyf+axyd*fid*dilckb
            dlepi=dlpi*aexyf+axyd*fid1*(deli*dili+enli*dilpi)
            dlepkb=dlpkb*aexyf+axyd*fid*(delkb*dilkb+enlkb*dilpkb)
            dleei=dlei*aexyf+axyd*fid1*(delei*dili+enli*dilei)
            dleekb=dlekb*aexyf+axyd*fid*(delekb*dilkb+enlkb*dilekb)
            dleci=dlci*aexyf+axyd*fid1*(delci*dili+enli*dilci)
            dleckb=dlckb*aexyf+axyd*fid*(delckb*dilkb+enlkb*dilckb)
            dlcpi=dlpi*acxyf+axyd*fid1*(dcli*dili+cnli*dilpi)
            dlcpkb=dlpkb*acxyf+axyd*fid*(dclkb*dilkb+cnlkb*dilpkb)
            dlcei=dlei*acxyf+axyd*fid1*(dclei*dili+cnli*dilei)
            dlcekb=dlekb*acxyf+axyd*fid*(dclekb*dilkb+cnlkb*dilekb)
            dlcci=dlci*acxyf+axyd*fid1*(dclci*dili+cnli*dilci)
            dlcckb=dlckb*acxyf+axyd*fid*(dclckb*dilkb+cnlkb*dilckb)
            a_axy(nmat2avw+i) = axy

            bp(i+nrhs(1))=bp(i+nrhs(1))+axy
            bp(i+nrhs(4))=bp(i+nrhs(4))-axy
            a(idum+nmat(1))=a(idum+nmat(1))+dlapi
            a(idum+nmat(2))=a(idum+nmat(2))+dlaei
            a(idum+nmat(3))=a(idum+nmat(3))+dlaci
            a(idum+nmat(19))=a(idum+nmat(19))-dlapi
            a(idum+nmat(20))=a(idum+nmat(20))-dlaei
            a(idum+nmat(21))=a(idum+nmat(21))-dlaci
            a(idum+nmat(4))=a(idum+nmat(4))+dlapkb
            a(idum+nmat(5))=a(idum+nmat(5))+dlaekb
            a(idum+nmat(6))=a(idum+nmat(6))+dlackb
            a(idum+nmat(22))=a(idum+nmat(22))-dlapkb
            a(idum+nmat(23))=a(idum+nmat(23))-dlaekb
            a(idum+nmat(24))=a(idum+nmat(24))-dlackb

            bp(i+nrhs(2))=bp(i+nrhs(2))+aexy
            bp(i+nrhs(5))=bp(i+nrhs(5))-aexy
            a(idum+nmat(7))=a(idum+nmat(7))+dlepi
            a(idum+nmat(8))=a(idum+nmat(8))+dleei
            a(idum+nmat(9))=a(idum+nmat(9))+dleci
            a(idum+nmat(25))=a(idum+nmat(25))-dlepi
            a(idum+nmat(26))=a(idum+nmat(26))-dleei
            a(idum+nmat(27))=a(idum+nmat(27))-dleci
            a(idum+nmat(10))=a(idum+nmat(10))+dlepkb
            a(idum+nmat(11))=a(idum+nmat(11))+dleekb
            a(idum+nmat(12))=a(idum+nmat(12))+dleckb
            a(idum+nmat(28))=a(idum+nmat(28))-dlepkb
            a(idum+nmat(29))=a(idum+nmat(29))-dleekb
            a(idum+nmat(30))=a(idum+nmat(30))-dleckb

            bp(i+nrhs(3))=bp(i+nrhs(3))+acxy
            bp(i+nrhs(6))=bp(i+nrhs(6))-acxy
            a(idum+nmat(13))=a(idum+nmat(13))+dlcpi
            a(idum+nmat(14))=a(idum+nmat(14))+dlcei
            a(idum+nmat(15))=a(idum+nmat(15))+dlcci
            a(idum+nmat(31))=a(idum+nmat(31))-dlcpi
            a(idum+nmat(32))=a(idum+nmat(32))-dlcei
            a(idum+nmat(33))=a(idum+nmat(33))-dlcci
            a(idum+nmat(16))=a(idum+nmat(16))+dlcpkb
            a(idum+nmat(17))=a(idum+nmat(17))+dlcekb
            a(idum+nmat(18))=a(idum+nmat(18))+dlcckb
            a(idum+nmat(34))=a(idum+nmat(34))-dlcpkb
            a(idum+nmat(35))=a(idum+nmat(35))-dlcekb
            a(idum+nmat(36))=a(idum+nmat(36))-dlcckb

         endif
c
c     vapour phase calculations
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         pxyh=t2(neighc)
         sx4h=t7(neighc)
         vxyd=pxyh+0.5*sx4h*(rovf(i)+rovf(kb))
     *        *(cord(kz,igrav)-cord(iz,igrav))
         t8(neighc)=vxyd
c
c     determine upwind nodes and if vapour phase exists
c
c     isl=0
         jm=1
         kb=idl
         kz=kb
         neighc=1
         fid=.5
         vxyd=t8(neighc)
         if(vxyd.lt.0.0) fid=dnwgt
         if(vxyd.gt.0.0) fid=upwgt
         if(t4(neighc).lt.0.0) t9(neighc)=fid
         if(t4(neighc).gt.0.0) t9(neighc)=fid
c     if(swi+s(kb).ne.2.0) isl=1
c
c     form equations
c
         isl=1
         if(isl.ne.0) then
            jm=1
            kb=idl
            kz=kb
            neighc=1
            fid=t9(neighc)
            fid1=1.0-fid
            pxyh=t2(neighc)
            pvxy=t4(neighc)
            sx4h=t7(neighc)
            vxyd=t8(neighc)

            envkb=envf(kb)
            cnvkb=cnvf(kb)
            divpkb=divp(kb)
            divckb=divc(kb)
            divekb=dive(kb)
            devkb=devf(kb)
            devekb=devef(kb)
            devckb=devcf(kb)
            dcvkb=dcvf(kb)
            dcvekb=dcvef(kb)
            dcvckb=dcvcf(kb)
            divkb=div(kb)

            dvpi=-pvxy+0.5*sx4h*dgvp(i)*(cord(kz,igrav)-
     &           cord(iz,igrav))
            dvpkb=pvxy+0.5*sx4h*dgvp(kb)*(cord(kz,igrav)-
     &           cord(iz,igrav))
            dvei=0.5*sx4h*dgve(i)*(cord(kz,igrav)-cord(iz,igrav))
            dvekb=0.5*sx4h*dgve(kb)
     *           *(cord(kz,igrav)-cord(iz,igrav))
            dvci=0.5*sx4h*dgvc(i)*(cord(kz,igrav)-cord(iz,igrav))
            dvckb=0.5*sx4h*dgvc(kb)*(cord(kz,igrav)-cord(iz,igrav))

            vexyf=(fid*divkb*envkb+fid1*divi*envi)
            vxyf=(fid*divkb+fid1*divi)
            vcxyf=(fid*divkb*cnvkb+fid1*divi*cnvi)
            vexy=vxyd*vexyf
            vxy=vxyd*vxyf
            vcxy=vxyd*vcxyf
            dvapi=dvpi*vxyf+vxyd*fid1*divpi
            dvapkb=dvpkb*vxyf+vxyd*fid*divpkb
            dvaei=dvei*vxyf+vxyd*fid1*divei
            dvaekb=dvekb*vxyf+vxyd*fid*divekb
            dvaci=dvci*vxyf+vxyd*fid1*divci
            dvackb=dvckb*vxyf+vxyd*fid*divckb
            dvepi=dvpi*vexyf+vxyd*fid1*(devi*divi+envi*divpi)
            dvepkb=dvpkb*vexyf+vxyd*fid*(devkb*divkb+envkb*divpkb)
            dveei=dvei*vexyf+vxyd*fid1*(devei*divi+envi*divei)
            dveekb=dvekb*vexyf+vxyd*fid*(devekb*divkb+envkb*divekb)
            dveci=dvci*vexyf+vxyd*fid1*(devci*divi+envi*divci)
            dveckb=dvckb*vexyf+vxyd*fid*(devckb*divkb+envkb*divckb)
            dvcpi=dvpi*vcxyf+vxyd*fid1*(dcvi*divi+cnvi*divpi)
            dvcpkb=dvpkb*vcxyf+vxyd*fid*(dcvkb*divkb+cnvkb*divpkb)
            dvcei=dvei*vcxyf+vxyd*fid1*(dcvei*divi+cnvi*divei)
            dvcekb=dvekb*vcxyf+vxyd*fid*(dcvekb*divkb+cnvkb*divekb)
            dvcci=dvci*vcxyf+vxyd*fid1*(dcvci*divi+cnvi*divci)
            dvcckb=dvckb*vcxyf+vxyd*fid*(dcvckb*divkb+cnvkb*divckb)
            a_vxy(nmat2avw+i) = vxy

            bp(i+nrhs(1))=bp(i+nrhs(1))+vxy
            bp(i+nrhs(4))=bp(i+nrhs(4))-vxy
            a(idum+nmat(1))=a(idum+nmat(1))+dvapi
            a(idum+nmat(2))=a(idum+nmat(2))+dvaei
            a(idum+nmat(3))=a(idum+nmat(3))+dvaci
            a(idum+nmat(19))=a(idum+nmat(19))-dvapi
            a(idum+nmat(20))=a(idum+nmat(20))-dvaei
            a(idum+nmat(21))=a(idum+nmat(21))-dvaci
            a(idum+nmat(4))=a(idum+nmat(4))+dvapkb
            a(idum+nmat(5))=a(idum+nmat(5))+dvaekb
            a(idum+nmat(6))=a(idum+nmat(6))+dvackb
            a(idum+nmat(22))=a(idum+nmat(22))-dvapkb
            a(idum+nmat(23))=a(idum+nmat(23))-dvaekb
            a(idum+nmat(24))=a(idum+nmat(24))-dvackb

            bp(i+nrhs(2))=bp(i+nrhs(2))+vexy
            bp(i+nrhs(5))=bp(i+nrhs(5))-vexy
            a(idum+nmat(7))=a(idum+nmat(7))+dvepi
            a(idum+nmat(8))=a(idum+nmat(8))+dveei
            a(idum+nmat(9))=a(idum+nmat(9))+dveci
            a(idum+nmat(25))=a(idum+nmat(25))-dvepi
            a(idum+nmat(26))=a(idum+nmat(26))-dveei
            a(idum+nmat(27))=a(idum+nmat(27))-dveci
            a(idum+nmat(10))=a(idum+nmat(10))+dvepkb
            a(idum+nmat(11))=a(idum+nmat(11))+dveekb
            a(idum+nmat(12))=a(idum+nmat(12))+dveckb
            a(idum+nmat(28))=a(idum+nmat(28))-dvepkb
            a(idum+nmat(29))=a(idum+nmat(29))-dveekb
            a(idum+nmat(30))=a(idum+nmat(30))-dveckb

            bp(i+nrhs(3))=bp(i+nrhs(3))+vcxy
            bp(i+nrhs(6))=bp(i+nrhs(6))-vcxy
            a(idum+nmat(13))=a(idum+nmat(13))+dvcpi
            a(idum+nmat(14))=a(idum+nmat(14))+dvcei
            a(idum+nmat(15))=a(idum+nmat(15))+dvcci
            a(idum+nmat(31))=a(idum+nmat(31))-dvcpi
            a(idum+nmat(32))=a(idum+nmat(32))-dvcei
            a(idum+nmat(33))=a(idum+nmat(33))-dvcci
            a(idum+nmat(16))=a(idum+nmat(16))+dvcpkb
            a(idum+nmat(17))=a(idum+nmat(17))+dvcekb
            a(idum+nmat(18))=a(idum+nmat(18))+dvcckb
            a(idum+nmat(34))=a(idum+nmat(34))-dvcpkb
            a(idum+nmat(35))=a(idum+nmat(35))-dvcekb
            a(idum+nmat(36))=a(idum+nmat(36))-dvcckb
            if(iadif.ne.0) then
c
c     add air-water vapor diffusion
c
c
c     determine upwind nodes and if vapour phase exists
c
               jm=1
               kb=idl
               neighc=1
               fid=.5
               vxyd=t10(neighc)*(cnvf(kb)-cnvi)
               if ( vxyd.lt.0.0) fid=dnwgt
               if ( vxyd.gt.0.0) fid=upwgt
c              t9(neighc)=0.5
c use matrix values
               t9(neighc)=1.0
               dvai=dva(i)
               envmi=enva(i)
               devmpi=denvap(i)
               devmei=denvae(i)
               devmci=denvac(i)
               devmpi=devmpi*dvai+envmi*ddvap(i)
               devmei=devmei*dvai+envmi*ddvae(i)
               devmci=devmci*dvai+envmi*ddvac(i)
               jm=1
               kb=idl
               kz=kb-icd
               neighc=1
               heatc=t10(neighc)
               fid=t9(neighc)
               fid1=1.0-fid
c     energy equation
               envmkb=enva(kb)
               dvmpkb=denvap(kb)
               dvmekb=denvae(kb)
               dvmckb=denvac(kb)
               dvakb=dva(kb)
               dvmckb=dvmckb*dvakb+envmkb*ddvac(kb)
               dvmekb=dvmekb*dvakb+envmkb*ddvae(kb)
               dvmpkb=dvmpkb*dvakb+envmkb*ddvap(kb)
               dvame=(fid*dvakb*envmkb+fid1*dvai*envmi)
               bp(i+nrhs(2))=bp(i+nrhs(2))+heatc*dvame*
     &              (cnvf(kb)-cnvi)
               bp(i+nrhs(5))=bp(i+nrhs(5))-heatc*dvame*
     &              (cnvf(kb)-cnvi)
               a(idum+nmat(7))=a(idum+nmat(7))+heatc*(devmpi*fid1
     &              *(cnvf(kb)-cnvi)-dvame*dcvf(i))
               a(idum+nmat(8))=a(idum+nmat(8))+heatc*(devmei*fid1
     &              *(cnvf(kb)-cnvi)-dvame*dcvef(i))
               a(idum+nmat(9))=a(idum+nmat(9))+heatc*(devmci*fid1
     &              *(cnvf(kb)-cnvi)-dvame*dcvcf(i))
               a(idum+nmat(25))=a(idum+nmat(25))-heatc*(devmpi*fid1
     &              *(cnvf(kb)-cnvi)-dvame*dcvf(i))
               a(idum+nmat(26))=a(idum+nmat(26))-heatc*(devmei*fid1
     &              *(cnvf(kb)-cnvi)-dvame*dcvef(i))
               a(idum+nmat(27))=a(idum+nmat(27))-heatc*(devmci*fid1
     &              *(cnvf(kb)-cnvi)-dvame*dvam*dcvef(i))
               a(idum+nmat(10))=a(idum+nmat(10))+heatc*(dvmpkb*fid
     &              *(cnvf(kb)-cnvi)+dvame*dcvf(kb))
               a(idum+nmat(11))=a(idum+nmat(11))+heatc*(dvmekb*fid
     &              *(cnvf(kb)-cnvi)+dvame*dcvef(kb))
               a(idum+nmat(12))=a(idum+nmat(12))+heatc*(dvmckb*fid
     &              *(cnvf(kb)-cnvi)+dvame*dcvcf(kb))
               a(idum+nmat(28))=a(idum+nmat(28))-heatc*(dvmpkb*fid
     &              *(cnvf(kb)-cnvi)+dvame*dcvf(kb))
               a(idum+nmat(29))=a(idum+nmat(29))-heatc*(dvmekb*fid
     &              *(cnvf(kb)-cnvi)+dvame*dcvef(kb))
               a(idum+nmat(30))=a(idum+nmat(30))-heatc*(dvmckb*fid
     &              *(cnvf(kb)-cnvi)+dvame*dcvcf(kb))
c     air equation
               dvakb=dva(kb)
               dvam=(fid*dvakb+fid1*dvai)
               bp(i+nrhs(3))=bp(i+nrhs(3))+heatc*dvam*(cnvf(kb)-cnvi)
               bp(i+nrhs(6))=bp(i+nrhs(6))-heatc*dvam*(cnvf(kb)-cnvi)
               a(idum+nmat(13))=a(idum+nmat(13))+heatc*(ddvap(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvf(i))
               a(idum+nmat(14))=a(idum+nmat(14))+heatc*(ddvae(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvef(i))
               a(idum+nmat(15))=a(idum+nmat(15))+heatc*(ddvac(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvcf(i))
               a(idum+nmat(31))=a(idum+nmat(31))-heatc*(ddvap(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvf(i))
               a(idum+nmat(32))=a(idum+nmat(32))-heatc*(ddvae(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvef(i))
               a(idum+nmat(33))=a(idum+nmat(33))-heatc*(ddvac(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvef(i))
               a(idum+nmat(16))=a(idum+nmat(16))+heatc*(ddvap(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvf(kb))
               a(idum+nmat(17))=a(idum+nmat(17))+heatc*(ddvae(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvef(kb))
               a(idum+nmat(18))=a(idum+nmat(18))+heatc*(ddvac(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvcf(kb))
               a(idum+nmat(34))=a(idum+nmat(34))-heatc*(ddvap(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvf(kb))
               a(idum+nmat(35))=a(idum+nmat(35))-heatc*(ddvae(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvef(kb))
               a(idum+nmat(36))=a(idum+nmat(36))-heatc*(ddvac(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvcf(kb))
c    water equation
               dvakb=dva(kb)
               dvam=(fid*dvakb+fid1*dvai)
               bp(i+nrhs(1))=bp(i+nrhs(1))-heatc*dvam*(cnvf(kb)-cnvi)
               bp(i+nrhs(4))=bp(i+nrhs(4))+heatc*dvam*(cnvf(kb)-cnvi)
               a(idum+nmat( 1))=a(idum+nmat( 1))-heatc*(ddvap(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvf(i))
               a(idum+nmat( 2))=a(idum+nmat( 2))-heatc*(ddvae(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvef(i))
               a(idum+nmat( 3))=a(idum+nmat( 3))-heatc*(ddvac(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvcf(i))
               a(idum+nmat(19))=a(idum+nmat(19))+heatc*(ddvap(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvf(i))
               a(idum+nmat(20))=a(idum+nmat(20))+heatc*(ddvae(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvef(i))
               a(idum+nmat(21))=a(idum+nmat(21))+heatc*(ddvac(i)*fid1
     &              *(cnvf(kb)-cnvi)-dvam*dcvef(i))
               a(idum+nmat( 4))=a(idum+nmat( 4))-heatc*(ddvap(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvf(kb))
               a(idum+nmat( 5))=a(idum+nmat( 5))-heatc*(ddvae(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvef(kb))
               a(idum+nmat( 6))=a(idum+nmat( 6))-heatc*(ddvac(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvcf(kb))
               a(idum+nmat(22))=a(idum+nmat(22))+heatc*(ddvap(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvf(kb))
               a(idum+nmat(23))=a(idum+nmat(23))+heatc*(ddvae(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvef(kb))
               a(idum+nmat(24))=a(idum+nmat(24))+heatc*(ddvac(kb)*fid
     &              *(cnvf(kb)-cnvi)+dvam*dcvcf(kb))
            endif
         endif
c
c     add heat conduction
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         heatc=t5(neighc)
         iau=it11(jm)
         ial=it12(jm)
         jml=nelmdg(kb)-neqp1
         heatc=t5(neighc)
         bp(i+nrhs(2))=bp(i+nrhs(2))+heatc*(t(kb)-ti)
         bp(i+nrhs(5))=bp(i+nrhs(5))-heatc*(t(kb)-ti)
         a(idum+nmat(7))=a(idum+nmat(7))-heatc*dtpa(i)
         a(idum+nmat(8))=a(idum+nmat(8))-heatc*dtpae(i)
         a(idum+nmat(9))=a(idum+nmat(9))-heatc*dtpac(i)
         a(idum+nmat(25))=a(idum+nmat(25))+heatc*dtpa(i)
         a(idum+nmat(26))=a(idum+nmat(26))+heatc*dtpae(i)
         a(idum+nmat(27))=a(idum+nmat(27))+heatc*dtpac(i)
         a(idum+nmat(10))=a(idum+nmat(10))+heatc*dtpa(kb)
         a(idum+nmat(11))=a(idum+nmat(11))+heatc*dtpae(kb)
         a(idum+nmat(12))=a(idum+nmat(12))+heatc*dtpac(kb)
         a(idum+nmat(28))=a(idum+nmat(28))-heatc*dtpa(kb)
         a(idum+nmat(29))=a(idum+nmat(29))-heatc*dtpae(kb)
         a(idum+nmat(30))=a(idum+nmat(30))-heatc*dtpac(kb)
      enddo

      return
      end


!-----------------------------------------------------------------------
!     Program:       STELLOPT (v2.0)
!     Authors:       S. Lazerson
!     Date:          05/24/2012
!     Description:   The STELLOPT v2.0 code is a versatile optimizer
!                    which fits MHD equilibria to target parameters.
!     References:
!-----------------------------------------------------------------------
      PROGRAM STELLOPT
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stellopt_runtime
      USE stellopt_input_mod
      USE mpi_params
      USE mpi_inc
      USE equil_utils, ONLY: move_txtfile
!-----------------------------------------------------------------------
!     Local Variables
!          numargs      Number of input arguments
!          i            Index
!          arg_len      Length of input strings
!          arg1         Input file
!          args         Input arguments
!-----------------------------------------------------------------------
      IMPLICIT NONE
      logical                                      :: ltst
      integer                                      :: numargs,i,ier,color,key
      integer, parameter                           :: arg_len =256
      character*(arg_len)                          :: arg1
      character*(arg_len),allocatable,dimension(:) :: args
      character(256)                               :: tstr1,tstr2
!-----------------------------------------------------------------------
!     Begin Program
!-----------------------------------------------------------------------

      myid = master
!DEC$ IF DEFINED (MPI_OPT)
      CALL MPI_INIT( ierr_mpi )                                         ! MPI
      color = 0
      CALL MPI_COMM_SPLIT( MPI_COMM_WORLD,color,myid,MPI_COMM_STEL,ierr_mpi)
      CALL MPI_COMM_RANK( MPI_COMM_STEL, myid, ierr_mpi )              ! MPI
      CALL MPI_COMM_SIZE( MPI_COMM_STEL, numprocs, ierr_mpi )          ! MPI
      CALL MPI_ERRHANDLER_SET(MPI_COMM_WORLD,MPI_ERRORS_RETURN,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_ERR,'stellopt_main',ierr_mpi)
!DEC$ ENDIF
      pi = 4.0 * ATAN(1.0)
      pi2 = 8.0 * ATAN(1.0)
      mu0 = 16.0E-7 * ATAN(1.0)
      lneed_output = .false.
      lrestart = .false.
      ltriangulate = .false.
      lno_restart = .false.
      lauto_domain = .false.
      lrenorm      = .false.
      pct_domain = 0.05
      xvec_file = 'xvec.dat'
      INQUIRE(UNIT=6,NAME=screen_str) ! Store STDOUT
      IF (myid == master) THEN
         !OPEN(6,CARRIAGECONTROL='fortran')
         numargs=0
         i=0
         arg1=''
         lverb    = .true.
         id_string     = ''

         ! First Handle the input arguments
         CALL GETCARG(1, arg1, numargs)
         ALLOCATE(args(numargs))
         ! Get filename
         CALL GETCARG(1,id_string,numargs)
         id_string=TRIM(id_string)
         id_string=ADJUSTL(id_string)
         id_string=TRIM(id_string)
         id_tag=id_string
         ! Cycle through Arguments
         i=2
         DO WHILE (i <= numargs)
            call GETCARG(i,args(i),numargs)
            select case (args(i))
               case ("-restart") ! Use restart file in directory
                  lrestart = .true.
               case ("-noverb")  ! No Verbose Output
                  lverb=.false.
               case ("-renorm")  ! No Verbose Output
                  lrenorm=.true.
               case ("-log")
                  screen_str = "log."//id_string(7:)
                  CLOSE(UNIT=6)
                  OPEN(UNIT=6,FILE=TRIM(screen_str))
               case ("-autodomain")  ! No Verbose Output
                  lauto_domain = .true.
                  i=i+1
                  call GETCARG(i,args(i),numargs)
                  READ(args(i),*) pct_domain
               case ("-tri")
                  i=i+1
                  call GETCARG(i,args(i),numargs)
                  i=i+1
                  call GETCARG(i,args(i),numargs)
                  CALL stellopt_triangulate(args(i-1),args(i))
                  ltriangulate = .true.
               case ("-xvec_file")
                  i=i+1
                  call GETCARG(i,args(i),numargs)
                  xvec_file = args(i)
               case ("-help","-h") ! Output Help message
                  write(6,*)' STELLOPT Optimizer '
                  WRITE(6,'(a,f5.2)') '  Version: ',STELLOPT_VERSION
                  write(6,*)' Usage: xstelloptv2 input_file <options>'
                  write(6,*)'    <options>'
                  write(6,*)'     -restart          Restart a run from reset file'
                  write(6,*)'     -renorm           Renormalize sigmas'
                  write(6,*)'     -autodomain pct   Automatically calculate min-max domain'
                  write(6,*)'     -noverb           Supress all screen output'
                  write(6,*)'     -log              Output screen to log file'
                  write(6,*)'     -tri file1 file2  Triangulation files'
                  write(6,*)'     -xvec_file file   X_VEC filename (OPT_TYPE: EVAL_XVEC)'
                  write(6,*)'     -help:            Output help message'
!DEC$ IF DEFINED (MPI_OPT)
                  call MPI_ABORT( MPI_COMM_STEL, master, ierr_mpi )
!DEC$ ENDIF
            end select
            i = i + 1
         END DO
         DEALLOCATE(args)
         WRITE(6,'(a,f5.2)') 'STELLOPT Version ',STELLOPT_VERSION
      ELSE
         lverb=.false.   ! Shutup the slaves
      END IF
      ! Broadcast variables
!DEC$ IF DEFINED (MPI_OPT)
      CALL MPI_BCAST(lrestart,1,MPI_LOGICAL, master, MPI_COMM_STEL,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR,'stellopt_main',ierr_mpi)
      CALL MPI_BCAST(lrenorm,1,MPI_LOGICAL, master, MPI_COMM_STEL,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR,'stellopt_main',ierr_mpi)
      CALL MPI_BCAST(ltriangulate,1,MPI_LOGICAL, master, MPI_COMM_STEL,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR,'stellopt_main',ierr_mpi)
      CALL MPI_BCAST(lauto_domain,1,MPI_LOGICAL, master, MPI_COMM_STEL,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR,'stellopt_main',ierr_mpi)
      CALL MPI_BCAST(pct_domain,1,MPI_REAL8, master, MPI_COMM_STEL,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR,'stellopt_main',ierr_mpi)
      CALL MPI_BCAST(id_string,256,MPI_CHARACTER, master, MPI_COMM_STEL,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR,'stellopt_main',ierr_mpi)
      CALL MPI_BCAST(id_tag,256,MPI_CHARACTER, master, MPI_COMM_STEL,ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR,'stellopt_main',ierr_mpi)
      CALL MPI_BARRIER( MPI_COMM_STEL, ierr_mpi )
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BARRIER_ERR,'stellopt_main',ierr_mpi)
!DEC$ ENDIF
      ! Initialize the Calculation
      CALL stellopt_init

      ! The following commands will only be completed by master
      IF (myworkid == master .and. lrenorm) THEN
         ! Now do one run with renorm
         tstr1 = opt_type
         opt_type = 'one_iter_norm'
         CALL stellopt_optimize

         ! Now cleaup some files
         CALL MPI_FILE_DELETE('stellopt.'//TRIM(id_string), MPI_INFO_NULL, ierr_mpi)

         ! Now initalize using min file
         opt_type = tstr1
         IF (myid == master) THEN
            CALL stellopt_write_inputfile(0,.true.)
            CALL move_txtfile('input.'//TRIM(id_string) //'_min','input.'//TRIM(id_string) // '_norm')
            WRITE(6,*) ''
            WRITE(6,*) ' ---------------------  RESTARTING WITH NEW NORMALIZTION  --------------------'
            WRITE(6,*) ''
         END IF
         id_string = 'input.' // TRIM(id_string) // '_norm'
         CALL MPI_FILE_OPEN(MPI_COMM_STEL, TRIM(id_string), &
                            MPI_MODE_RDONLY, MPI_INFO_NULL, key, ierr_mpi )
         CALL MPI_FILE_CLOSE(key,ier)
         CALL read_stellopt_input(TRIM(id_string),ier,myid)

         ! Now fix a couple things before we re-run the optimizer
         id_string = id_string(7:LEN(id_string))
         lrenorm = .false.
      END IF

      IF (myworkid == master) THEN
         CALL stellopt_optimize
         ltst  = .false.
         tstr1 = 'exit'
         tstr2 = ''
         CALL stellopt_paraexe(tstr1,tstr2,ltst)
      END IF

      ! All procs (master and workers) will do this part
      ! Clean up
!DEC$ IF DEFINED (MPI_OPT)
      CALL MPI_COMM_FREE(MPI_COMM_STEL, ierr_mpi)
      CALL MPI_FINALIZE(ierr_mpi)
      IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_FINE_ERR,'stellot_main',ierr_mpi)
!DEC$ ENDIF
      IF (lverb) WRITE(6,'(A)')'----- STELLOPT DONE -----'

!-----------------------------------------------------------------------
!     End Program
!-----------------------------------------------------------------------
      END PROGRAM STELLOPT


C
C $Id: mdrgsx.f,v 1.14 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MDRGSX (ICAT,ICEL,IRIM,ILAT,ILON,IFLL,IRGL,
     +                                         IAMA,LAMA,XCRA,YCRA,MCRA)
C
        INTEGER ICAT,ICEL,IRIM,ILAT,ILON,IFLL,IRGL,IAMA(LAMA),LAMA,MCRA
        REAL XCRA(MCRA),YCRA(MCRA)
C
C This routine, given the file identifiers ICAT, ICEL, and IRIM for a
C particular level of the RANGS/GSHHS data, and the integer latitude and
C longitude ILAT and ILON (-90.LE.ILAT.LE.89 and 0.LE.ILON.LE.359) of
C the lower left-hand corner of a particular 1-degree square, retrieves
C the polygons for that square, checks them against a list of polygons
C that self-intersect, edits them if they do, and then does with them
C what is implied by the value of IFLL.  If IFLL is 0, portions of the
C polygon that do not lie on the edges of the 1-degree square are drawn.
C If IFLL is 1, the polygons are filled directly, without going through
C an area map.  If IFLL is 2, the polygons are drawn using an area map,
C which allows for transparency situations that IFLL=1 does not.  IRGL
C is the level at which the RANGS/GSHHS data is being used, required
C here for the call to MDRGED.  The array IAMA is an area map array.
C The arrays XCRA and YCRA are used to hold the coordinates of points
C defining polygons retrieved from the data arrays.
C
C Declare required common blocks.  See MAPBDX for descriptions of these
C common blocks and the variables in them.
C
        COMMON /MAPRGD/  ICOL(5),ICSF(5),IDPF,LCRA,NILN,NILT,OLAT,OLON
        INTEGER          ICOL,ICSF,IDPF,LCRA,NILN,NILT
        REAL             OLAT,OLON
        SAVE   /MAPRGD/
C
C Declare the routine that will fill the areas.
C
        EXTERNAL         MDRGFA
C
C Declare local variables.
C
        INTEGER          I,IAAI(1),IAGI(1),ICWP,IFLG,ILEV,IPGB,IPID,
     +                   IPOS,ISGB,ISTA,ITML,ITMP,ITYP,LNLG,NCRA,NPTS
C
        REAL             XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT
C
        DOUBLE PRECISION PLAT,PLON,QLAT,QLON,RLAT,RLON
C
C CTM4 and CTM1 are character temporaries into which we can read a group
C of four bytes or a single byte, respectively.  (Because the data are
C written in a byte-swapped fashion, we cannot read a four-byte quantity
C as if it were an integer; instead, we must read the four bytes and put
C the integer together.)
C
        CHARACTER*4 CTM4
        CHARACTER*1 CTM1
C
C Define an amended version of the FORTRAN function ICHAR that will work
C on machines like the IBM, which sign-extend eight-bit characters.
C
        CHARACTER*1 CARG
C
        ICHARF(CARG)=MOD(ICHAR(CARG)+256,256)
C
C Copy the specified values of ILAT and ILON to real variables in a
C common block to be passed to the area-fill routine MDRGFA.
C
        OLAT=REAL(ILAT)
        OLON=REAL(ILON)
C
C Copy the value of MCRA to an integer variable in a common block to
C be passed to the routine MDRGIP.
C
        LCRA=MCRA
C
C Initialize the area map.
C
        IF (IFLL.GE.2) CALL ARINAM (IAMA,LAMA)
C
C Save the current SET state and re-do it in a manner allowing for the
C mapping of lat/lon points from the chosen 1-degree square to the whole
C plotter frame.
C
        CALL GETSET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
        CALL SET    (0.,1.,0.,1.,0.,1.,0.,1.,1)
C
C Zero the polygon-level counter and the count of polygon points saved.
C
        ILEV=0
        NCRA=0
C
C Look in the catalog for a pointer to the definition of the desired
C 1-degree square in the cell file.
C
        CALL NGSEEK (ICAT,4*((89-ILAT)*360+ILON),0,ISTA)
C
        IF (ISTA.LT.0) THEN
          CALL SETER ('MDRGSX - SEEK FAILURE IN CAT FILE',1,1)
          RETURN
        END IF
C
        CALL NGRDCH (ICAT,CTM4,4,ISTA)
C
        IF (ISTA.NE.4) THEN
          CALL SETER ('MDRGSX - READ FAILURE IN CAT FILE',2,1)
          RETURN
        END IF
C
        IPOS=IOR(ISHIFT(IOR(ISHIFT(IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                        ICHARF(CTM4(3:3))),8),
     +                                        ICHARF(CTM4(2:2))),8),
     +                                        ICHARF(CTM4(1:1)))-1
C
C Position the cell file to the start of the definition.
C
        CALL NGSEEK (ICEL,IPOS,0,ISTA)
C
        IF (ISTA.LT.0) THEN
          CALL SETER ('MDRGSX - SEEK FAILURE IN CEL FILE',3,1)
          RETURN
        END IF
C
C Read a new polygon byte.
C
  101   CALL NGRDCH (ICEL,CTM1,1,ISTA)
C
        IF (ISTA.NE.1) THEN
          CALL SETER ('MDRGSX - READ FAILURE IN CEL FILE',4,1)
          RETURN
        END IF
C
        IPGB = ICHARF(CTM1)
C
C If the polygon byte is non-zero, we are at the start of a new polygon.
C
        IF (IPGB.NE.0) THEN
C
C Bump the value of ILEV by one.  This is done because the definition
C of a polygon is recursive; it can itself include one or more interior
C polygons that form holes in it.  Each polygon begins with a non-zero
C polygon byte and ends with a zero polygon byte; if, when we read for
C a polygon byte, we get a non-zero value, we know that a new level of
C recursion is beginning.
C
          ILEV=ILEV+1
C
C Read the polygon ID.
C
          CALL NGRDCH (ICEL,CTM4,4,ISTA)
C
          IF (ISTA.NE.4) THEN
            CALL SETER ('MDRGSX - READ FAILURE IN CEL FILE',5,1)
            RETURN
          END IF
C
          IPID=IOR(ISHIFT(IOR(ISHIFT(IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                          ICHARF(CTM4(3:3))),8),
     +                                          ICHARF(CTM4(2:2))),8),
     +                                          ICHARF(CTM4(1:1)))
C
C Zero IFLG.  It gets set non-zero when we have found the first point
C of the polygon, positive if that point is on the edge of the 1-degree
C cell, negative if otherwise.
C
          IFLG=0
C
C Zero ITMP.  This is done because we save the previous value of ITMP
C in ITML; it prevents ITML from getting a garbage value.
C
          ITMP=0
C
C Read a new segment byte.
C
  102     CALL NGRDCH (ICEL,CTM1,1,ISTA)
C
          IF (ISTA.NE.1) THEN
            CALL SETER ('MDRGSX - READ FAILURE IN CEL FILE',6,1)
            RETURN
          END IF
C
          ISGB = ICHARF(CTM1)
C
C The low-order three bits of the segment byte tell us what follows.
C Pull them off into ITMP, saving the previous value as ITML.
C
          ITML=ITMP
          ITMP=IAND(ISGB,7)
C
C If ITMP is non-zero, extract a three-bit integer that tells us the
C type of the polygon we're working on (0 => ocean, 1 => land, 2 =>
C lake, 3 => island in lake, 4 => pond on island) and a one-bit integer
C that says whether it is defined in a clockwise or counterclockwise
C direction.
C
          IF (ITMP.NE.0) THEN
            ITYP=IAND(ISHIFT(ISGB,-4),7)
            ICWP=IAND(ISHIFT(ISGB,-3),1)
          END IF
C
C If ITMP is between 1 and 6, inclusive, it specifies a number of
C points defined by values read from the cell file; each point is
C defined by two 4-byte integers, the first a longitude and the
C second a latitude, in units of millionths of a degree.  All of these
C points are on the edge of the 1-degree cell.
C
          IF (ITMP.GE.1.AND.ITMP.LE.6) THEN
C
            NPTS = ITMP
C
C Loop to read the points.
C
            DO 105 I=1,NPTS
C
C Read a longitude.
C
              CALL NGRDCH (ICEL,CTM4,4,ISTA)
C
              IF (ISTA.NE.4) THEN
                CALL SETER ('MDRGSX - READ FAILURE IN CEL FILE',7,1)
                RETURN
              END IF
C
              QLON=RLON
C
              RLON=.000001D0*DBLE(IOR(ISHIFT(IOR(ISHIFT(
     +                       IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                  ICHARF(CTM4(3:3))),8),
     +                                  ICHARF(CTM4(2:2))),8),
     +                                  ICHARF(CTM4(1:1)))-1000000*ILON)
C
C Read a latitude.
C
              CALL NGRDCH (ICEL,CTM4,4,ISTA)
C
              IF (ISTA.NE.4) THEN
                CALL SETER ('MDRGSX - READ FAILURE IN CEL FILE',8,1)
                RETURN
              END IF
C
              QLAT=RLAT
C
              RLAT=.000001D0*DBLE(IOR(ISHIFT(IOR(ISHIFT(
     +                       IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                  ICHARF(CTM4(3:3))),8),
     +                                  ICHARF(CTM4(2:2))),8),
     +                                  ICHARF(CTM4(1:1)))-1000000*ILAT)
C
C If we had not yet seen the first point of the polygon (that is to
C say, if IFLG is zero), this is it; save its longitude and latitude
C and set IFLG to say that the first point was on the cell boundary.
C
              IF (IFLG.EQ.0) THEN
                PLON=RLON
                PLAT=RLAT
                IFLG=+1
              END IF
C
C Insert the point in the list.
C
              IF (NCRA+1.LT.MCRA) THEN
                NCRA=NCRA+1
                XCRA(NCRA)=REAL(RLON)
                YCRA(NCRA)=REAL(RLAT)
                IF (NCRA.GT.1) THEN
                  IF (XCRA(NCRA).EQ.XCRA(NCRA-1).AND.
     +                YCRA(NCRA).EQ.YCRA(NCRA-1)) NCRA=NCRA-1
                END IF
              ELSE
                CALL SETER ('MDRGSX - COORDINATE BUFFER OVERFLOW',9,1)
                RETURN
              END IF
C
  105       CONTINUE
C
C Go back to read another segment byte.
C
            GO TO 102
C
C If ITMP is a 7, then the next two values in the cell file are 4-byte
C integers, the first of which is a pointer into the rim file and the
C second of which is the number of points to be read from the rim file.
C Each point in the rim file is defined like a point in the cell file,
C by a pair of 4-byte integers, specifying longitude and latitude, in
C millionths of a degree.  All of the points in the rim file are in
C the interior of the 1-degree cell.
C
          ELSE IF (ITMP.EQ.7) THEN
C
C Get the pointer into the rim file.
C
            CALL NGRDCH (ICEL,CTM4,4,ISTA)
C
            IF (ISTA.NE.4) THEN
              CALL SETER ('MDRGSX - READ FAILURE IN CEL FILE',10,1)
              RETURN
            END IF
C
            IPOS=IOR(ISHIFT(IOR(ISHIFT(IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                            ICHARF(CTM4(3:3))),8),
     +                                            ICHARF(CTM4(2:2))),8),
     +                                            ICHARF(CTM4(1:1)))-1
C
C Get the number of points to be read from the rim file.
C
            CALL NGRDCH (ICEL,CTM4,4,ISTA)
C
            IF (ISTA.NE.4) THEN
              CALL SETER ('MDRGSX - READ FAILURE IN CEL FILE',11,1)
              RETURN
            END IF
C
            NPTS=IOR(ISHIFT(IOR(ISHIFT(IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                            ICHARF(CTM4(3:3))),8),
     +                                            ICHARF(CTM4(2:2))),8),
     +                                            ICHARF(CTM4(1:1)))
C
C If the number of points to be read is non-zero (for some reason, it
C *can* happen that the number is zero), read the points.
C
            IF (NPTS.NE.0) THEN
C
C Position to the start of the list of points in the rim file.
C
              CALL NGSEEK (IRIM,IPOS,0,ISTA)
C
              IF (ISTA.LT.0) THEN
                CALL SETER ('MDRGSX - SEEK FAILURE IN RIM FILE',12,1)
                RETURN
              END IF
C
C Loop to read the points.
C
              DO 106 I=1,NPTS
C
C Read a longitude.
C
                CALL NGRDCH (IRIM,CTM4,4,ISTA)
C
                IF (ISTA.NE.4) THEN
                  CALL SETER ('MDRGSX - READ FAILURE IN RIM FILE',13,1)
                  RETURN
                END IF
C
                QLON=RLON
C
                RLON=.000001D0*DBLE(IOR(ISHIFT(IOR(ISHIFT(
     +                       IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                  ICHARF(CTM4(3:3))),8),
     +                                  ICHARF(CTM4(2:2))),8),
     +                                  ICHARF(CTM4(1:1)))-1000000*ILON)
C
C Read a latitude.
C
                CALL NGRDCH (IRIM,CTM4,4,ISTA)
C
                IF (ISTA.NE.4) THEN
                  CALL SETER ('MDRGSX - READ FAILURE IN RIM FILE',14,1)
                  RETURN
                END IF
C
                QLAT=RLAT
C
                RLAT=.000001D0*DBLE(IOR(ISHIFT(IOR(ISHIFT(
     +                       IOR(ISHIFT(ICHARF(CTM4(4:4)),8),
     +                                  ICHARF(CTM4(3:3))),8),
     +                                  ICHARF(CTM4(2:2))),8),
     +                                  ICHARF(CTM4(1:1)))-1000000*ILAT)
C
C If we had not yet seen the first point of the polygon (that is to
C say, if IFLG is zero), this is it; save its longitude and latitude
C and set IFLG to say that the first point was not on the cell boundary.
C
                IF (IFLG.EQ.0) THEN
                  PLON=RLON
                  PLAT=RLAT
                  IFLG=-1
                END IF
C
C Since all of these points are interior points, we just add their
C coordinates to the point-coordinate buffers.
C
                IF (NCRA+1.LT.MCRA) THEN
                  NCRA=NCRA+1
                  XCRA(NCRA)=REAL(RLON)
                  YCRA(NCRA)=REAL(RLAT)
                  IF (NCRA.GT.1) THEN
                    IF (XCRA(NCRA).EQ.XCRA(NCRA-1).AND.
     +                  YCRA(NCRA).EQ.YCRA(NCRA-1)) NCRA=NCRA-1
                  END IF
                ELSE
                  CALL SETER
     +                      ('MDRGSX - COORDINATE BUFFER OVERFLOW',15,1)
                  RETURN
                END IF
C
  106         CONTINUE
C
            END IF
C
C Go back to read another segment byte.
C
            GO TO 102
C
          END IF
C
C If ITMP is zero, we've reached the end of the polygon.  We must supply
C a closure point (the first point of the polygon) and then fill the
C polygon.  Output the fill area.  First, see if at least one point is
C defined in the buffers.
C
          IF (NCRA.GT.1) THEN
C
C Add the coordinates of the closure point to the buffers, edit the
C polygon, and take the desired action (draw portions of it that lie
C in the interior of the unit square, fill it directly, or send it to
C an area map).  The statement beginning "IF (ILAT.GE.55 ... " is
C necessary to fix an error in the GSHHS/RANGS database.
C
            IF (XCRA(NCRA).NE.REAL(PLON).OR.
     +          YCRA(NCRA).NE.REAL(PLAT)) THEN
              NCRA=NCRA+1
              XCRA(NCRA)=REAL(PLON)
              YCRA(NCRA)=REAL(PLAT)
              IF (NCRA.GT.1) THEN
                IF (XCRA(NCRA).EQ.XCRA(NCRA-1).AND.
     +              YCRA(NCRA).EQ.YCRA(NCRA-1)) NCRA=NCRA-1
              END IF
            END IF
C
            IF (NCRA.GT.1) THEN
              IF (ILAT.GE.55.AND.ILAT.LE.57.AND.ILON.EQ.82.AND.
     +                                                 ITYP.EQ.2) ITYP=1
              CALL MDRGED (IRGL,IPID,ILAT,ILON,ICWP,XCRA,YCRA,NCRA,MCRA)
              IF (IFLL.EQ.0) THEN
                CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
                CALL MDRGDR (XCRA,YCRA,NCRA,ITYP+1)
                CALL SET    (0.,1.,0.,1.,0.,1.,0.,1.,1)
              ELSE IF (IFLL.EQ.1) THEN
                CALL MDRGIP (XCRA,YCRA,NCRA)
                CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
                CALL MDRGFP (XCRA,YCRA,NCRA,ITYP+1)
                CALL SET    (0.,1.,0.,1.,0.,1.,0.,1.,1)
              ELSE
                IF (ICWP.NE.0) THEN
                  CALL MDRGAM (IAMA,XCRA,YCRA,NCRA,1,ITYP+1,ITYP)
                ELSE
                  CALL MDRGAM (IAMA,XCRA,YCRA,NCRA,1,ITYP,ITYP+1)
                END IF
              END IF
            END IF
C
          END IF
C
C Zero the count of coordinates in the point-coordinate buffer.
C
          NCRA=0
C
C Go back to read another polygon byte.
C
          GO TO 101
C
C If the polygon byte is zero, it says that we've hit the end of a
C polygon.
C
        ELSE
C
C Reduce the recursion counter by one and, if it's still non-zero, go
C back to read another polygon byte.
C
          ILEV=ILEV-1
          IF (ILEV.NE.0) GO TO 101
C
        END IF
C
C Scan the area map, retrieving polygons from it, mapping them as
C directed by the current state of EZMAP, and filling them.
C
        IF (IFLL.GE.2) THEN
          CALL ARGETI ('RC(1)',IRC1)
          CALL ARSETI ('RC(1)',0)
          CALL ARSCAM (IAMA,XCRA,YCRA,MCRA,IAAI,IAGI,1,MDRGFA)
          CALL ARSETI ('RC(1)',IRC1)
        END IF
C
C Restore the original SET state.
C
        CALL SET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
C
C Normal return.
C
        RETURN
C
      END


*DECK PGSF
      FUNCTION PGSF (X, IZ, C, A, BH)
C***BEGIN PROLOGUE  PGSF
C***SUBSIDIARY
C***PURPOSE  Subsidiary to CBLKTR
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (PGSF-S)
C***AUTHOR  (UNKNOWN)
C***SEE ALSO  CBLKTR
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  PGSF
      DIMENSION       A(*)       ,C(*)       ,BH(*)
C***FIRST EXECUTABLE STATEMENT  PGSF
      FSG = 1.
      HSG = 1.
      DO 101 J=1,IZ
         DD = 1./(X-BH(J))
         FSG = FSG*A(J)*DD
         HSG = HSG*C(J)*DD
  101 CONTINUE
      IF (MOD(IZ,2)) 103,102,103
  102 PGSF = 1.-FSG-HSG
      RETURN
  103 PGSF = 1.+FSG+HSG
      RETURN
      END