      program potent
c
c**********************************************************************
c
c     dl_poly utility program
c
c     construct potential arrays for silver iodide
c     based on model by Ray, Rahman and Vashishta:
c     Superionics and Solid Electrolytes, Academic Press 1989
c
c     copyright - daresbury laboratory 1994
c     author    - w. smith july 1994
c
c**********************************************************************
c
      implicit real*8(a-h,o-z)
      parameter (mxgrid=2000,ntable=10)
      dimension uuu(mxgrid,3),ggg(mxgrid,3),elrc(3),vlrc(3)
      character*8 silver,iodine
      write(*,'(a)')'dl_poly utility to create potential tables for'
      write(*,'(a)')'Ray-Rahman-Vashista silver iodide potential'
      write(*,*)
      write(*,'(a)')'Please specify potential cutoff range (rcut)'
      read(*,*) rcut
      write(*,'(a)')'Please specify number of grid points (mxgrid)'
      read(*,*) maxgrd
      if(maxgrd.gt.mxgrid)then
         write(*,'(a)')'Error - too many grid points requested'
         stop
      endif
      rpd=rcut/dble(maxgrd-4)
      silver='Ag+     '
      iodine='I-      '

c
c     silver-iodine potential
      j=1
      do i=1,maxgrd
        rrr=dble(i)*rpd
        rsq=rrr**2
        uuu(i,j)=14.39d0*(114.48d0/rrr**5-1.1736d0)/rsq**2
        ggg(i,j)=14.39d0*(9.d0*114.48d0/rrr**5-4.d0*1.1736d0)/rsq**2
      enddo
      elrc(1)=14.39d0*(114.48d0/(6.d0*rcut**6)-1.1736d0/rcut)
      vlrc(1)=-14.39d0*(9.d0*114.48d0/(6.d0*rcut**6)-4.d0*1.1736d0/rcut)
c
c     iodine-iodine potential
      j=2
      do i=1,maxgrd
        rrr=dble(i)*rpd
        rsq=rrr**2
        uuu(i,j)=14.39d0*(446.64d0/rrr**3-6.9331d0/rsq-2.3472d0)/rsq**2
        ggg(i,j)=14.39d0*(7.d0*446.64d0/rrr**3-6.d0*6.9331d0/rsq-
     x    4.d0*2.3472d0)/rsq**2
      enddo
      elrc(2)=14.39d0*(446.64d0/(4.d0*rcut**4)-6.9331d0/(3.d0*rcut**3)-
     x  2.3472d0/rcut)
      vlrc(2)=-14.39d0*(7.d0*446.64d0/(4.d0*rcut**4)-6.d0*6.9331d0/
     x  (3.d0*rcut**3)-4.d0*2.3472d0/rcut)
c
c     silver-silver potential
      j=3
      do i=1,maxgrd
        rrr=dble(i)*rpd
        rsq=rrr**2
        uuu(i,j)=14.39d0*(0.014804d0/rrr**11)
        ggg(i,j)=14.39d0*(11.d0*0.014804d0/rrr**11)
      enddo
      elrc(3)=14.39d0*(0.014804d0/(8.d0*rcut**8))
      vlrc(3)=-11.d0*14.39d0*(0.014804d0/(8.d0*rcut**8))
c
c     conversions to required units
      do  j=1,3
        elrc(j)=elrc(j)*1.60217733e-19/1.6605402e-23
        vlrc(j)=vlrc(j)*1.60217733e-19/1.6605402e-23
        do  i=1,maxgrd
          uuu(i,j)=uuu(i,j)*1.60217733e-19/1.6605402e-23
          ggg(i,j)=ggg(i,j)*1.60217733e-19/1.6605402e-23
        enddo
      enddo
c
c     write out potentials
      open(ntable,file='TABLE')
      write(ntable,'(a)')'Silver Iodide Potential - DL_POLY units'
      write(ntable,'(2e15.8,i10)')rpd,rcut,maxgrd
      do k=1,3
        if(k.eq.1)write(ntable,'(2a8,1p,2e15.8)')
     x    silver,iodine,elrc(1),vlrc(1)
        if(k.eq.2)write(ntable,'(2a8,1p,2e15.8)')
     x    iodine,iodine,elrc(2),vlrc(2)
        if(k.eq.3)write(ntable,'(2a8,1p,2e15.8)')
     x    silver,silver,elrc(3),vlrc(3)
        write(ntable,'(4e15.8)')(uuu(i,k),i=1,maxgrd)
        write(ntable,'(4e15.8)')(ggg(i,k),i=1,maxgrd)
      enddo
      close (ntable)
      stop
      end


      SUBROUTINE sigmoid(x,y,dyda,param)
C     Levenburg Marquart subroutine.
C     Returns y and grad y (wrt fitting parameters)
C     at a point x, according to the sigmoid function
C     Iobs=B + (K/Q^4)*EXP(-sigma^2*Q^2)
C
C     Often leads to "IEEE" errors.
C     Debug in progress.
C
      DIMENSION param(3),dyda(3)

      dyda(1)=1.

      temp1=x*x
      temp4=1./x
      temp4=temp4*temp4
      temp2=-temp1*param(3)*param(3)
      IF (temp2 .GT. 16.) THEN
        temp3=1.E+8
      ELSEIF (temp2 .LT. -16.) THEN
        temp3=0.
      ELSE
        temp3=EXP(temp2)
      ENDIF

C     Estimate size of results
      xlg=LOG10(ABS(x))
      a=-4.*xlg
      IF (param(2) .NE. 0.) THEN
        porlg=LOG10(ABS(param(2)))
        c=porlg-4.*xlg
      ELSE
        porlg=0.
        c=0.
      ENDIF
      IF (param(3) .NE. 0. .AND. param(2) .NE. 0.) THEN
        siglg=LOG10(ABS(param(3)))
        b=siglg+porlg-2.*xlg
      ELSE
        b=0.
      ENDIF

C     Take care of y
      IF (c .GT. 8.) THEN
        y=1.E+8
      ELSEIF (c .LT. -8.) THEN
        y=0.
      ELSE
        y=param(2)*temp3
        y=y*temp4
        y=y*temp4
        y=y+param(3)
      ENDIF

C     Take care of deriv. wrt K
      IF (a .GT. 8.) THEN
        dyda(2)=1.E+8
      ELSEIF (a .LT. -8.) THEN
        dyda(2)=0.
      ELSE
        dyda(2)=temp3*temp4
        dyda(2)=dyda(2)*temp4
      ENDIF

C     Take care of deriv. wrt sig
      IF (b .GT. 8.) THEN
        dyda(3)=1.E+8
      ELSEIF (b .LT. -8.) THEN
        dyda(3)=0.
      ELSE
        dyda(3)=-2.*param(2)*param(3)*temp3
        dyda(3)=dyda(3)*temp4
      ENDIF

C      IF (ABS(y) .GT. 1.0E+8) THEN
C        write(6,*)'Debug warning!'
C      ENDIF

      RETURN
      END


!	Find standard errors of distractor frequencies and relative frequencies.
!   choices provides the number of choices for each item.
!   dat provides item data.
!   distdat provides distractor data.
!   distmap maps distractors to item scores.
!	npsu is the number of psus's per stratum.
!	nstratum is the number of strata.
!   numcatobs provides the number of categories for item scores.
!	psu indicates the psu of an observation.
!	stratum indicates the stratum of an observation.
!	complx indicates complex sampling.
!	stratify is .true. for stratified sampling.
!	usepsu is .true. for primary sampling units within strata.

!   distfreq provides distractor frequencies.

!   distprob provides conditional distractor probabilities.
!   obsweight gives observation weights.
!   scorefreq provides item score frequencies.
!	sdfreq gives standard errors for frequencies.
!	sdprob gives standard errors for probabilities.
subroutine sdfreqs(choices,dat,distdat,distmap,npsu,nstratum,numcatobs,obsweight,&
    psu,stratum,complx,stratify,usepsu,distfreq,distprob,scorefreq,sdfreq,sdprob)
implicit none
interface
!	The following description is for the function's basic purpose.
!	Its use in this subroutine is a bit different.
!	Estimate the information matrix for a complex sample.
!	This version is designed for random sampling of psu's within strata.
!	Sampling is with replacement.
!	npsu is the number of psus's per stratum.
!	nstratum is the number of strata.
!	psu indicates the psu of an observation.
!	stratum indicates the stratum of an observation.
!	stratify is .true. for stratified sampling.
!	usepsu is .true. for primary sampling units within strata.
!	grads is the array of observation gradients.
!	obsweight contains observation weights.

    function information_complex(npsu,nstratum,psu,stratum,stratify,usepsu,grads,obsweight)
        implicit none
        integer,intent(in)::nstratum
        integer,intent(in),optional::npsu(:),psu(:),stratum(:)
        logical,intent(in)::stratify,usepsu
        real(kind=8),intent(in)::grads(:,:),obsweight(:)
        real(kind=8)::information_complex(size(grads,1),size(grads,1))
    end function information_complex
end interface

integer,intent(in)::choices(:),dat(:,:),distdat(:,:),distmap(:),npsu(:),nstratum,numcatobs(:),&
	psu(:),stratum(:)
logical,intent(in)::complx,stratify,usepsu
real(kind=8),intent(in)::distfreq(:),distprob(:),obsweight(:),scorefreq(:)
real(kind=8),intent(out)::sdfreq(:),sdprob(:)
!   a1 is an allocation indicator.
!   col is a distractor for an item.
!   counter marks distractors.

!	item is an item.

!	nitems is the number of items.

!	nobs is number of observations.
!   numchoices is total number of distractors.

!	obs counts observations.
!   position is a position of an item score
!   positiondist is a position of a distractor score.
!	resp is a response.
!   resdidst is a distractor response.
!   row is an item marker

integer::al,col,counter,item,nitems,nobs,numchoices,&
	obs,position,positiondist,resp,respdist,row

!	covobs is the covariance matrix for adjusted observed values.

!	obsmat is the array of response indicators and fits.
!		The first row is the observed indicator.
!		The second is 1 if consistent with the item score and 0 otherwise.

real(kind=8)::covobs(1,1)
real(kind=8),allocatable::obsmat(:,:)
!

!	Set up parameter arrays for simplified processing.

nitems=size(dat,1)
nobs=size(obsweight)
numchoices=sum(choices)
sdfreq=0.0_8
sdprob=0.0_8
!   Complex sampling requires an examimation of individual cases.
if(complx)then
	allocate(obsmat(2,nobs),stat=al)
	if(al/=0) stop 'Allocation of array failed for standard errors of distractor frequencies and proportions.'
    counter=1
    positiondist=1
    row=1
    do item=1,nitems
        do col=1,choices(item)
            if(distmap(counter)>=0) then
                obsmat=0.0_8
                do obs=1,nobs

                    if(obsweight(obs)<=0.0_8) cycle
                    resp=dat(item,obs)
                    respdist=distdat(item,obs)
                    if(resp<0.or.resp>=numcatobs(item))cycle

!	Verify if item score was observed.
                    position=distmap(positiondist+respdist)

                    if(resp==position-row)then
                        obsmat(2,obs)=1.0_8
                        if(respdist==col-1)obsmat(1,obs)=1.0_8

                    end if
                end do
                row=distmap(counter)
                covobs=information_complex(npsu,nstratum,psu,stratum,stratify,usepsu,&
					obsmat(1:1,:),obsweight)
                sdfreq(counter)=sqrt(covobs(1,1))

                obsmat(1,:)=obsmat(1,:)-distprob(counter)*obsmat(2,:)
                covobs=information_complex(npsu,nstratum,psu,stratum,stratify,usepsu,&
                    obsmat(1:1,:),obsweight)
                sdprob(counter)=sqrt(covobs(1,1)/scorefreq(row))
            end if
            counter=counter+1
        end do
        row=row+numcatobs(item)
        positiondist=positiondist+choices(item)
    end do
else

    do counter=1,numchoices
        row=distmap(counter)
        if(row<0) cycle
		sdfreq(counter)=distfreq(counter)*(1.0_8-distprob(counter))
        sdprob(counter)=sqrt(sdfreq(counter)/scorefreq(row))
        sdfreq(counter)=sqrt(sdfreq(counter))
    end do
end if

if(complx)deallocate(obsmat)
return
end subroutine sdfreqs


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Sparse Stoichiometric Data Structures File
!
! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : kpp_achem_gas_StoichiomSP.f90
! Time                 : Thu Jun 11 11:33:46 2015
! Working directory    : /gpfsm/dnb32/adarmeno/models/geos-5/heracles-UNSTABLE-DEV_MICROPHYSICS/src/GEOSgcs_GridComp/GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphV
! Equation file        : kpp_achem_gas.kpp
! Output root filename : kpp_achem_gas
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE kpp_achem_gas_StoichiomSP

  USE kpp_achem_gas_Precision
  PUBLIC
  SAVE

! Row-compressed sparse data for the Jacobian of reaction products JVRP

  INTEGER, PARAMETER, DIMENSION(6) :: CROW_JVRP = (/ &
       1,  2,  3,  4,  5,  6 /)

  INTEGER, PARAMETER, DIMENSION(5) :: ICOL_JVRP = (/ &
       1,  1,  1,  2,  3 /)

  INTEGER, PARAMETER, DIMENSION(5) :: IROW_JVRP = (/ &
       1,  2,  3,  4,  5 /)

!  Stoichiometric Matrix in Compressed Column Sparse Format

  INTEGER, PARAMETER, DIMENSION(6) :: CCOL_STOICM = (/ &
       1,  3,  6,  8, 10, 11 /)

  INTEGER, PARAMETER, DIMENSION(10) :: IROW_STOICM = (/ &
       1,  2,  1,  2,  4,  1,  2,  2,  5,  3 /)

  INTEGER, PARAMETER, DIMENSION(10) :: ICOL_STOICM = (/ &
       1,  1,  2,  2,  2,  3,  3,  4,  4,  5 /)

  REAL(kind=dp), PARAMETER, DIMENSION(10) :: STOICM = (/ &
       -1.000000e+00_dp,  1.000000e+00_dp,  -1.000000e+00_dp,  7.500000e-01_dp,  2.500000e-01_dp, &
       -1.000000e+00_dp,  1.000000e+00_dp,  -1.000000e+00_dp,  1.000000e+00_dp,  -1.000000e+00_dp /)

END MODULE kpp_achem_gas_StoichiomSP


subroutine nr_doublings(              &
     accuracy,    ns_elas,   nsmax,   &
     k,           maxlay,    m,       &
     maxleg,      gmumin,    wl_Ray,  &
     omega_Ray,   tautot,    ndl)

!-----------------------------------------------------------
! Subroutine:
!    nr_doublings
!
! Purpose:
!    Determinine number of doublings
!    the number of sublayers and their optical thicknesses
!    for wavenumber ns_elas (elastic light),
!    for each Fourier component m, and
!    for each layer k
!
!-----------------------------------------------------------
! Based on De Haan 1987, Section 7.2
! In this paper it is assumed
! basic layer = 2nd order scattering layer.
! However, if basic layer=1st order works adequately adequately
! as well (only 0.02 % difference).
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8)!double precision

  integer,intent(in):: &
    ns_elas,  &  !wavenumber index (elastic light)
    nsmax,    &  !nr of waveumbers
    k,        &  !layer index
    maxlay,   &  !nr of layers
    m,        &  !Fourier index
    maxleg       !maximum Legendre term index

  real(kind=dp),intent(in):: &
    accuracy,                & ! doubling-adding accuracy
    gmumin,                  & ! minimum quadrature angle (internal)
    wl_Ray(0:maxleg),        &
    omega_Ray(maxlay,0:nsmax), &
    tautot(maxlay,0:nsmax)

  integer::lg

  real(kind=dp):: &
     am,          &
     amtry,       &
     dtautot,     &
     fdtautotmu,  &
     rhs

  integer,intent(out)::ndl  !nr of doublings

  logical,parameter::screendump=.false.

!----------------------------------------------------------------
! Effective single scattering albedo Eq.(143)
!----------------------------------------------------------------

  am = 0.d0
  do lg=m,maxleg
     amtry = omega_Ray(k,ns_elas)*abs(wl_Ray(lg))/dble(2*lg+1)
     if(am.lt.amtry) am = amtry
  enddo

!----------------------------------------------------------------
! Right hand side Eq.(142)
!----------------------------------------------------------------

  rhs = 4.d0*accuracy/(9.d0*tautot(k,ns_elas)*(am**3)*dble(2*m+1))

  ndl = -1
  dtautot = 2.d0*tautot(k,ns_elas)
100 continue
  ndl = ndl + 1
  dtautot= 0.5d0*dtautot
  fdtautotmu = dtautot/gmumin
  if(fdtautotmu.gt.1.d0) fdtautotmu = 1.d0
  if(dtautot.ge.(rhs/fdtautotmu)) goto 100
  if(dtautot.ge.(1.d0/3.d0)) goto 100

  if(screendump)then
     write(*,'(3I4,A22,(1p,D15.7),A20,(0p,I4))')  &
       k,ns_elas,m,'Initial opt.depth =',dtautot, &
          'Nr of doublings =',ndl
  endif

  return
end subroutine nr_doublings


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                     C
C  ROUTINE FILLING THE ARRAY INCLUDING ALL ANGULAR INTEGRALS          C
C   FOR THE STOP PAIR HADROPRODUCTION   [ SOFT ]                      C
C                                                                     C
C                                                                     C
C     SOFT_ARRAY(SOFTIN,SOF1)                                         C
C                                                                     C
C                                                                     C
C  INPUT  :   SOFTIN(1:4)    CONTAINING   S,T1,U1,MS1^2               C
C                                                                     C
C  OUTPUT :   SOF1(1:8)     ALL THE FINITE PARTS OF THE SOFT          C
C                            INTEGRALS ACCORDING TO ROLAND            C
C                                                                     C
C  N.B. : THE INTEGRALS ARE OF THE FORM                               C
C                                                                     C
C         PI * DELTA^EE/MS1^EE * SOF1(1)                              C
C          = INT_0^DELTA     S4^(1-2*EE)/(S4+MS1^2)^(1-EE)            C
C            INT D(OMEGA_N)  1/S4^2                                   C
C                                                                     C
C  CALLED FUNCTIONS : LIR2(X)                                         C
C                                                                     C
C                                                                     C
C  NECESSARY SUBROUTINES : XSPENCE                                    C
C                                                                     C
C                                                                     C
C  LAST MODIFIED : 21.10.96                                           C
C                                                                     C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c --------------------------------------------------------------------
c --------------------------------------------------------------------
      subroutine SOFT_ARRAY_LQ(m2,sof1)

      implicit none

      integer n
      real*8 m2(4),sof1(8)
      real*8 zeta2,xw,xx,Lir2,s
      complex*16 CSPEN

      Lir2(s) = real( CSPEN(dcmplx(s)) )

      zeta2 = ( 4.D0*atan(1.D0) )**2 /6.D0
      xw = sqrt( 1.D0 - 4.D0*m2(4)/m2(1) )
      xx = ( 1.D0 - xw )/( 1.D0 + xw )

c --------------------------
c  1/(s4^2)
      sof1(3) = - 2.D0/m2(4)

c  1/(s3*s4)
      sof1(1) = 2.D0/(m2(1)*xw)*(  2.D0*Lir2(xx) + 2.D0*Lir2(-xx)
     &                           - log(xx)**2
     &                           + 2.D0*log(xx)*log(1.D0-xx**2)
     &                           - zeta2                        )

c  1/(tp*s4)
      sof1(4) = - 3.D0*zeta2 / (2.D0*m2(3))

c  1/(up*s4)
      sof1(5) = - 3.D0*zeta2 / (2.D0*m2(2))

c  1/(s3^2)
      sof1(2) = 2.D0/m2(4)*
     &          (m2(1)-2.D0*m2(4))*log(xx)/(m2(1)*xw)

c  1/(tp*up)
      sof1(8) = 2.D0/m2(1)*( log(m2(2)*m2(3)/m2(1)/m2(4))**2 /2.D0
     &                     + Lir2(1.D0 - m2(1)*m2(4)/m2(2)/m2(3) )
     &                     - 3.D0/2.D0 * zeta2 )

c  1/(up*s3)
      sof1(7) = ( - 2.D0*log(xx)*log(m2(3)/m2(2))
     &            - log(xx)**2
     &            + log(m2(3)/m2(2))**2
     &            + 2.D0*Lir2(1.D0-m2(3)/(m2(2)*xx))
     &            - 2.D0*Lir2(1.D0-m2(2)/(m2(3)*xx))
     &            - 3.D0/2.D0*zeta2                  )/m2(3)

c  1/(tp*s3)
      sof1(6) = ( - 2.D0*log(xx)*log(m2(2)/m2(3))
     &            - log(xx)**2
     &            + log(m2(2)/m2(3))**2
     &            + 2.D0*Lir2(1.D0-m2(2)/(m2(3)*xx))
     &            - 2.D0*Lir2(1.D0-m2(3)/(m2(2)*xx))
     &            - 3.D0/2.D0*zeta2                  )/m2(2)

c adjust the right prefactor

      do 996 n = 1,8
 996     sof1(n) = sof1(n)/8.D0

      end


 SUBROUTINE centdiff

    USE basic
    USE fields
    USE constants
    USE futils
    !
    ! Computes the derivatives which
    ! will be used to find the electric field.

    INTEGER           :: k,l,i,j
    DOUBLE PRECISION :: d1,d2,d1inv,d2inv,d12inv
    INTEGER :: phi_unit=45,Er_unit=46,Ez_unit=47,Erz_unit=48
    character (305) :: file_phi,file_Er,file_Ez,file_Erz
    file_phi = "phi1"
    file_Er = "Er1"
    file_Ez = "Ez1"
    file_Erz = "Erz1"

    d1 = dr
    d2 = dz

    d1inv = 0.5/d1
    d2inv = 0.5/d2
    d12inv = d1inv*d2inv

    ! next, fill in the last row/column to match the zeroths
    es_potgrid_t(numrpts,:,:) = es_potgrid_t(0,:,:)
    es_potgrid_t(:,numzpts,:) = es_potgrid_t(:,0,:)

    ! find the specialty values for the zeroth and last rows
    dpotdrtiltgrid_t(0,:,:) = d1inv*(es_potgrid_t(1,:,:) - es_potgrid_t(numrpts - 1,:,:))
    dpotdrtiltgrid_t(numrpts,:,:) = dpotdrtiltgrid_t(0,:,:)
    ! do the usual centered differencing
    DO i=1,numrpts-1
      dpotdrtiltgrid_t(i,:,:) = d1inv*(es_potgrid_t(i + 1,:,:) - es_potgrid_t(i - 1,:,:))
    END DO

    ! find the specialty values for the zeroth and last columns
    dpotdztiltgrid_t(:,0,:) = d2inv*(es_potgrid_t(:,1,:)  - es_potgrid_t(:,numzpts - 1,:))
    dpotdztiltgrid_t(:,numzpts,:) = dpotdztiltgrid_t(:,0,:)
    ! do the usual centered differencing
    DO j=1,numzpts-1
      dpotdztiltgrid_t(:,j,:) = d2inv*(es_potgrid_t(:,j + 1,:) - es_potgrid_t(:,j - 1,:))
    END DO

    ! find the specialty values for the zeroth and last columns and rows
    DO j=1,numrpts-1
      d2potdrdztiltgrid_t(j,0,:) = &
      d12inv*(es_potgrid_t(j+1,1,:) - es_potgrid_t(j+1,numzpts-1,:) - es_potgrid_t(j-1,1,:) + &
      es_potgrid_t(j-1,numzpts-1,:))
    END DO
    DO k=1,numzpts-1
      d2potdrdztiltgrid_t(0,k,:) = &
      d12inv*(es_potgrid_t(1,k+1,:) - es_potgrid_t(numrpts-1,k+1,:) - es_potgrid_t(1,k-1,:) + &
      es_potgrid_t(numrpts-1,k-1,:))
    END DO
    ! the 0,0 position requires extra care
    d2potdrdztiltgrid_t(0,0,:) = &
    d12inv*(es_potgrid_t(1,1,:) - es_potgrid_t(numrpts-1,1,:) - es_potgrid_t(1,numzpts-1,:) + &
    es_potgrid_t(numrpts-1,numzpts-1,:))
    ! fill in the last row/column to match the zeroth
    d2potdrdztiltgrid_t(:,numzpts,:) = d2potdrdztiltgrid_t(:,0,:)
    d2potdrdztiltgrid_t(numrpts,:,:) = d2potdrdztiltgrid_t(0,:,:)
    ! do the usual centered differencing for the bidirectional derivative
    DO j=1,numrpts-1
      DO k=1,numzpts-1
        d2potdrdztiltgrid_t(j,k,:) = &
           d12inv*(es_potgrid_t(j+1,k+1,:) - es_potgrid_t(j+1,k-1,:) - es_potgrid_t(j-1,k+1,:) + &
           es_potgrid_t(j-1,k-1,:))
      END DO
    END DO

    IF (firstframeout) THEN
      open(phi_unit, file=file_phi, STATUS='REPLACE') ! the choice of tracer_unit here is completely arbitrary
      open(Er_unit, file=file_Er, STATUS='REPLACE') ! the choice of tracer_unit here is completely arbitrary
      open(Ez_unit, file=file_Ez, STATUS='REPLACE') ! the choice of tracer_unit here is completely arbitrary
      open(Erz_unit, file=file_Erz, STATUS='REPLACE') ! the choice of tracer_unit here is completely arbitrary
      do j=0,numrpts
      	do k=0,numzpts
	        write(phi_unit,*) j, k, es_potgrid_t(j,k,0)
	        write(Er_unit,*)  j, k, dpotdrtiltgrid_t(j,k,0)
	        write(Ez_unit,*)  j, k, dpotdztiltgrid_t(j,k,0)
	        write(Erz_unit,*) j, k, d2potdrdztiltgrid_t(j,k,0)
     	end do
      end do
      close(phi_unit)
      close(Er_unit)
      close(Ez_unit)
      close(Erz_unit)
   END IF

  END SUBROUTINE centdiff


! find surface normals
module surf_normals
implicit none
contains

subroutine cell_normals(nhat, x, dx, i1, i2, ihat)
real, intent(out) :: nhat(:,:,:,:)
real, intent(in) :: x(:,:,:,:), dx(3)
integer, intent(in) :: i1(3), i2(3), ihat
integer :: j, k, l, a, b, c
real :: h

nhat = 0.0
h = sign(0.5, product(dx))

do a = 1, 3
    b = modulo(a,   3) + 1
    c = modulo(a+1, 3) + 1
    select case (ihat)
    case (1)
        j = i1(1)
        do l = i1(3), i2(3)
        do k = i1(2), i2(2)
            nhat(1,k,l,a) = h * &
            ( (x(j,k+1,l,b) - x(j,k,l+1,b)) * (x(j,k+1,l+1,c) - x(j,k,l,c)) &
            - (x(j,k+1,l,c) + x(j,k,l+1,c)) * (x(j,k+1,l+1,b) - x(j,k,l,b)) )
        end do
        end do
    case (2)
        k = i1(2)
        do l = i1(3), i2(3)
        do j = i1(1), i2(1)
            nhat(j,1,l,a) = h * &
            ( (x(j,k,l+1,b) - x(j+1,k,l,b)) * (x(j+1,k,l+1,c) - x(j,k,l,c)) &
            - (x(j,k,l+1,c) + x(j+1,k,l,c)) * (x(j+1,k,l+1,b) - x(j,k,l,b)) )
        end do
        end do
    case (3)
        l = i1(3)
        do k = i1(2), i2(2)
        do j = i1(1), i2(1)
            nhat(j,k,1,a) = h * &
            ( (x(j+1,k,l,b) - x(j,k+1,l,b)) * (x(j+1,k+1,l,c) - x(j,k,l,c)) &
            - (x(j+1,k,l,c) + x(j,k+1,l,c)) * (x(j+1,k+1,l,b) - x(j,k,l,b)) )
        end do
        end do
    case default; stop 'error: surfnormal'
    end select
end do

end subroutine

subroutine node_normals(nhat, x, dx, i1, i2, ihat)
real, intent(out) :: nhat(:,:,:,:)
real, intent(in) :: x(:,:,:,:), dx(3)
integer, intent(in) :: i1(3), i2(3), ihat
integer :: j, k, l, a, b, c
real :: h

nhat = 0.0
h = sign(1.0 / 12.0, product(dx))

do a = 1, 3
    b = modulo(a,   3) + 1
    c = modulo(a+1, 3) + 1
    select case (ihat)
    case (1)
        j = i1(1)
        do l = i1(3), i2(3)
        do k = i1(2), i2(2)
            nhat(1,k,l,a) = h * &
            ( x(j,k+1,l,b) * ( x(j,k,l+1,c) + x(j,k+1,l+1,c) &
                             - x(j,k,l-1,c) - x(j,k+1,l-1,c) ) &
            + x(j,k-1,l,b) * ( x(j,k,l-1,c) + x(j,k-1,l-1,c) &
                             - x(j,k,l+1,c) - x(j,k-1,l+1,c) ) &
            + x(j,k,l+1,b) * ( x(j,k-1,l,c) + x(j,k-1,l+1,c) &
                             - x(j,k+1,l,c) - x(j,k+1,l+1,c) ) &
            + x(j,k,l-1,b) * ( x(j,k+1,l,c) + x(j,k+1,l-1,c) &
                             - x(j,k-1,l,c) - x(j,k-1,l-1,c) ) &
            + x(j,k+1,l+1,b) * (x(j,k,l+1,c) - x(j,k+1,l,c)) &
            + x(j,k-1,l-1,b) * (x(j,k,l-1,c) - x(j,k-1,l,c)) &
            + x(j,k-1,l+1,b) * (x(j,k-1,l,c) - x(j,k,l+1,c)) &
            + x(j,k+1,l-1,b) * (x(j,k+1,l,c) - x(j,k,l-1,c)) )
        end do
        end do
    case (2)
        k = i1(2)
        do l = i1(3), i2(3)
        do j = i1(1), i2(1)
            nhat(j,1,l,a) = h * &
            ( x(j,k,l+1,b) * ( x(j+1,k,l,c) + x(j+1,k,l+1,c) &
                             - x(j-1,k,l,c) - x(j-1,k,l+1,c) ) &
            + x(j,k,l-1,b) * ( x(j-1,k,l,c) + x(j-1,k,l-1,c) &
                             - x(j+1,k,l,c) - x(j+1,k,l-1,c) ) &
            + x(j+1,k,l,b) * ( x(j,k,l-1,c) + x(j+1,k,l-1,c) &
                             - x(j,k,l+1,c) - x(j+1,k,l+1,c) ) &
            + x(j-1,k,l,b) * ( x(j,k,l+1,c) + x(j-1,k,l+1,c) &
                             - x(j,k,l-1,c) - x(j-1,k,l-1,c) ) &
            + x(j+1,k,l+1,b) * (x(j+1,k,l,c) - x(j,k,l+1,c)) &
            + x(j-1,k,l-1,b) * (x(j-1,k,l,c) - x(j,k,l-1,c)) &
            + x(j+1,k,l-1,b) * (x(j,k,l-1,c) - x(j+1,k,l,c)) &
            + x(j-1,k,l+1,b) * (x(j,k,l+1,c) - x(j-1,k,l,c)) )
        end do
        end do
    case (3)
        l = i1(3)
        do k = i1(2), i2(2)
        do j = i1(1), i2(1)
            nhat(j,k,1,a) = h * &
            ( x(j+1,k,l,b) * ( x(j,k+1,l,c) + x(j+1,k+1,l,c) &
                             - x(j,k-1,l,c) - x(j+1,k-1,l,c) ) &
            + x(j-1,k,l,b) * ( x(j,k-1,l,c) + x(j-1,k-1,l,c) &
                             - x(j,k+1,l,c) - x(j-1,k+1,l,c) ) &
            + x(j,k+1,l,b) * ( x(j-1,k,l,c) + x(j-1,k+1,l,c) &
                             - x(j+1,k,l,c) - x(j+1,k+1,l,c) ) &
            + x(j,k-1,l,b) * ( x(j+1,k,l,c) + x(j+1,k-1,l,c) &
                             - x(j-1,k,l,c) - x(j-1,k-1,l,c) ) &
            + x(j+1,k+1,l,b) * (x(j,k+1,l,c) - x(j+1,k,l,c)) &
            + x(j-1,k-1,l,b) * (x(j,k-1,l,c) - x(j-1,k,l,c)) &
            + x(j-1,k+1,l,b) * (x(j-1,k,l,c) - x(j,k+1,l,c)) &
            + x(j+1,k-1,l,b) * (x(j+1,k,l,c) - x(j,k-1,l,c)) )
        end do
        end do
    case default; stop 'error: surfnormal'
    end select
end do

end subroutine

end module


      subroutine genmulti(n,sh,school,nparam,curpars,
     $     parCPL,fRij,ndata,tps,rtn,ndays,epi_model)

      implicit none

      integer iday_per_week
      parameter(iday_per_week=7)
      integer nCPL
      parameter(nCPL=2)
      integer nstep
      parameter (nstep = 6)
      integer n, ndata, ndays, nparam
      integer epi_model
      real*8 sh(ndata,n), school(ndata,n)
      real*8 curpars(nparam,n)
      real*8 rtn(ndata,n)
      real*8 fN(n)
      real*8 pC(n)
      real*8 tps(ndata)
      real*8 e_bckgrnd(n)
      real*8 dsdt((ndays)*nstep,n)
! Unique to the coupling between regions
      real*8 fRij(n,n)
      real*8 parCPL(nCPL)
      real*8 fMij(n,n)
      integer imid((ndata+1))

!
! Need to find the mid-point
! This will need to be further cleaned - the CDC data is absolute day numbers..
!

      if (tps(1) > (iday_per_week * 10)) Then
         call BuildIMIDforCDC(ndata, nstep, tps, imid)
      else
         call BuildIMID(ndata, nstep, tps, imid)
      endif

! integrate the ODEs to get the profiles

      rtn = 0.0d0
      dsdt = 0.0d0

      fN = curpars(1, 1:n)
      pC = curpars(5, 1:n)
      e_bckgrnd = curpars(8, 1:n)

      fMij = 0.0d0

      call buildMij(n,nCPL,fN,fRij,parCPL,fMij)

      select case (epi_model)
         case (1)
             call RK4SIR(n,sh,school,ndata,ndays,nstep,tps,nparam,
     $            curpars,fMij,dsdt)
         case (2)
             call RK4SEIR(n,sh,school,ndata,ndays,nstep,tps,nparam,
     $            curpars,fMij,dsdt)
          case default
             call RK4SIR(n,sh,school,ndata,ndays,nstep,tps,nparam,
     $            curpars,fMij,dsdt)
      end select

      call weekly(n,ndata, ndays, nstep, imid, dsdt, pC,
     $     e_bckgrnd, rtn)

      return
      end subroutine genmulti


        subroutine gamma_errors(s,t,p,gamma,a,n,along,alat,
     &                                  s0,t0,p0,sns,tns,pns,kns,
     &                              gamma_ns,pth_error,scv_l_error,scv_h_error, ierr)
ccc
ccc
ccc
ccc     DESCRIPTION :   Find the p-theta and the scv errors associated
ccc                     with the basic neutral surface calculation
ccc
ccc     PRECISION :     Double
ccc
ccc     INPUT :         s(n)            array of Levitus cast salinities
ccc                     t(n)            array of cast in situ temperatures
ccc                     p(n)            array of cast pressures
ccc                     gamma(n)        array of cast neutral densities
ccc                     a(n)            array of cast quadratic coefficients
ccc                     n               length of cast
ccc                     along           longitude of Levitus cast
ccc                     alat            latitude of Levitus cast
ccc                     s0              bottle salinity
ccc                     t0              bottle temperature
ccc                     p0              bottle pressure
ccc                     sns             salinity of neutral surface on cast
ccc                     tns             temperature of neutral surface on cast
ccc                     pns             pressure of neutral surface on cast
ccc                     kns             index of neutral surface on cast
ccc                     gamma_ns        gamma value of neutral surface on cast
ccc
ccc     OUTPUT :        pth_error       p-theta gamma error bar
ccc                     scv_l_error     lower scv gamma error bar
ccc                     scv_h_error     upper scv gamma error bar
ccc
ccc     UNITS :         salinity        psu (IPSS-78)
ccc                     temperature     degrees C (IPTS-68)
ccc                     pressure        db
ccc                     gamma           kg m-3
ccc
ccc
ccc     AUTHOR :        David Jackett
ccc
ccc     CREATED :       March 1995
ccc
ccc     REVISION :      1.1             9/3/95
ccc
ccc
ccc
        parameter(nscv_max=50)

        implicit double precision (a-h,o-z)

        dimension s(n),t(n),p(n),gamma(n),a(n)

        dimension sscv_m(nscv_max),tscv_m(nscv_max),pscv_m(nscv_max)

        data pr0/0.0/, Tb/2.7e-8/, gamma_limit/26.845/, test_limit/0.1/

        ierr = 0
ccc
ccc             p-theta error
ccc

        th0 = theta(s0,t0,p0,pr0)
        thns = theta(sns,tns,pns,pr0)

        sdum = svan(sns,tns,pns,sig_ns)
        rho_ns = 1000+sig_ns

        call sig_vals(s(kns),t(kns),p(kns),s(kns+1),t(kns+1),p(kns+1),
     &                                                          sig_l,sig_h)

        b = (gamma(kns+1)-gamma(kns))/(sig_h-sig_l)

        dp = pns-p0
        dth = thns-th0

        pth_error = rho_ns*b*Tb*abs(dp*dth)/6

ccc
ccc             scv error
ccc

        scv_l_error = 0.0
        scv_h_error = 0.0

        if(alat.le.-60.0.or.gamma(1).ge.gamma_limit) then

          drldp = (sig_h-sig_l)/(rho_ns*(p(kns+1)-p(kns)))

          test = Tb*dth/drldp

cc
cc              approximation
cc

          if(abs(test).le.test_limit) then

            if(dp*dth.ge.0.0) then
              scv_h_error = (3*pth_error)/(1.0-test)
            else
              scv_l_error = (3*pth_error)/(1.0-test)
            end if

          else

cc
cc              explicit scv solution, when necessary
cc

            call depth_scv(s,t,p,n,s0,t0,p0,sscv_m,tscv_m,pscv_m,nscv, ierr)
            if(ierr.ne.0) then
                return
            end if

            if(nscv.eq.0) then

              continue

            else

              if(nscv.eq.1) then

                pscv = pscv_m(1)

              else

                pscv_mid = pscv_m((1+nscv)/2)

                if(p0.le.pscv_mid) then
                  pscv = pscv_m(1)
                else
                  pscv = pscv_m(nscv)
                end if

              end if

              call indx(p,n,pscv,kscv)
              call gamma_qdr(p(kscv),gamma(kscv),a(kscv),
     &                          p(kscv+1),gamma(kscv+1),pscv,gamma_scv)

              if(pscv.le.pns) then
                scv_l_error = gamma_ns-gamma_scv
              else
                scv_h_error = gamma_scv-gamma_ns
              end if

            end if

          end if

        else

          continue

        end if

ccc
ccc             check for positive gamma errors
ccc

        if(pth_error.lt.0.0.or.
     &          scv_l_error.lt.0.0.or.
     &                  scv_h_error.lt.0.0) then
        ierr = 6
        return
ccc       stop 'ERROR 1 in gamma-errors: negative scv error'

        end if

        return
        end


subroutine normal(pf)
!from physical to normalized ([0-1]) units

use share, only: dp, ndim, n_p, llimits, steps, ntie, indtie

implicit none

!params
real(dp), intent(inout) :: pf(ndim) ! full vector of parameters

!locals
real(dp)                :: ulimit
integer                 :: i

do i=1,ndim
  ulimit=llimits(i)+steps(i)*(n_p(i)-1)
  pf(i)=0.5_dp+(2._dp*pf(i)-llimits(i)-ulimit)/(2._dp*(ulimit-llimits(i)))
enddo

if (indtie(1) > 0) then
  do i=1,ntie
    if (pf(indtie(i)) < 0.0_dp) then
      pf(indtie(i))=0.0_dp
    else
        if (pf(indtie(i)) >= 1.0_dp) pf(indtie(i))=0.999999_dp
    endif
  enddo
endif

end


 subroutine fill_canopy(zmcf,nzc,nxc,nyc,nz,NumPatchType,canpdepth ,CanopyCmdepth, DBH,Height,PatchType,TotalLAI)

    implicit none

 ! Copyright: Gil Bohrer and Roni avissar, Duke University, 2006
  ! Input:
  ! zmcf - vector of vertical grid mesh heights in the domain into which the canopy should be extemded
  ! nxc,nyc - canopy dimensions from dims_pzRyx.txt
  ! NumPatchType - from dims_pzRyx.txt
  ! canpdepth - zRi from dims_pzRyx.txt
  ! CanopyCmdepth - length of zcm from dims_pzRyx.txt
  ! nz - length of zmcf , can be larger than nzc
  !
  ! It will read in the files generated by V-CaGe.m (except dims_pzRyx.txt that should be read earlier and its parameter values passed to this subroutine)

  ! This program assumes that Dx, Dy in the extended canopy domain are equal to Dx,Dy in the virtual canopy files
  ! It also assumes that nx=nxc, ny=nyc (but will not crash if nx<nxc and/or ny<nyc)

  ! Output
  ! 2-D V-CaGe Canopy arrays: DBH,Height,PatchType,TotalLAI
  ! 3-D canopy arrays:
  !            ZstemAreaU - projected stem area (on vertical plain)
  !            ZStemAreaW - projected stem area (on horizontal plain)
  !            CumulativeLAI -  Accumulated Leaf area / m^2 ground (from canopy top)

    character(200) , parameter :: CanopyInDir = '../CanopyInFiles'         !directory path to canopyIn files, generate by V-CaGe

    integer :: nzc,nxc,nyc,ng,nzcm,ncm,pt,nz,nzcc
    integer :: i,j,k,cm
    real :: kH
    real , dimension(nz) :: zmcf
    real, dimension(NumPatchType,CanopyCmdepth) :: CSProf,LAD
    real, dimension(CanopyCmdepth) :: zcm
    real, dimension(nxc,nyc) :: DBH,Height,TotalLAI
    integer, dimension(nxc,nyc) :: PatchType
    real, dimension(nzc,nxc,nyc) :: ZstemAreaU ,ZstemAreaW, CumulativeLAI

    print *, 'start fill canopy'
    if (nzc.lt.canpdepth) then
       print *,'model domain too shallow- below canopy top'
    else
       nzcc = canpdepth
    endif

    nzcm = CanopyCmdepth
    ZstemAreaU=0
    ZstemAreaV=0
    ZStemAreaW=0
    CumulativeLAI=0
    CanopyOut=0

    OPEN (21202,FILE=trim(CanopyInDir)//'/'//'CSProfiles.txt', STATUS='OLD')
    OPEN (21203,FILE=trim(CanopyInDir)//'/'//'DBH.txt', STATUS='OLD')
    OPEN (21204,FILE=trim(CanopyInDir)//'/'//'LAD.txt', STATUS='OLD')
    OPEN (21205,FILE=trim(CanopyInDir)//'/'//'Bowen.txt', STATUS='OLD')
    OPEN (21206,FILE=trim(CanopyInDir)//'/'//'Height.txt', STATUS='OLD')
    OPEN (21207,FILE=trim(CanopyInDir)//'/'//'patch.txt', STATUS='OLD')
    OPEN (21208,FILE=trim(CanopyInDir)//'/'//'TotLAI.txt', STATUS='OLD')
    OPEN (21209,FILE=trim(CanopyInDir)//'/'//'z.txt', STATUS='OLD')

    do j=1,nzcm
       read (21202,*) (CSProf(i,j),i=1,NumPatchType)
       read (21204,*) (LAD(i,j),i=1,NumPatchType)
       read (21209,*) zcm(j)
    enddo

    do j=1,nyc
       read (21203,*) (DBH(i,j),i=1,nxc)
       read (21205,*) (Bowen(i,j),i=1,nxc)
       read (21206,*) (Height(i,j),i=1,nxc)
       read (21207,*) (PatchType(i,j),i=1,nxc)
       read (21208,*) (TotalLAI(i,j),i=1,nxc)
    enddo

    close(21202)
    close(21203)
    close(21209)
    close(21204)
    close(21205)
    close(21206)
    close(21207)
    close(21208)

    print *, 'Done reading canopy init files for grid', ng

    do i=1,nxc
       do j=1,nyc

          kH = Height(i,j)*zcm(nzcm)
          pt = PatchType(i,j)
          CumulativeLAI(nzcc,i,j)=0.0
          cm=nzcm

          do k=(nzcc),2,-1

             CumulativeLAI(k,i,j)=0.0
             ncm=0

             do while (((zcm(cm)*kH).ge.zmcf(k-1)).and.(cm.gt.1))
                ncm=ncm+1

                CumulativeLAI(k,i,j)=CumulativeLAI(k,i,j)+LAD(pt,cm)
                cm=cm-1
             enddo

             CumulativeLAI(k,i,j)=CumulativeLAI(k,i,j)* &
                  TotalLAI(i,j)+CumulativeLAI(k+1,i,j)

          enddo
       enddo
    enddo

endsubroutine


! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_T3

USE Precision_Model, ONLY: stnd

Implicit NONE

PRIVATE

PUBLIC :: Rule_T3a
PRIVATE :: OrbT3_Sum

CONTAINS
    SUBROUTINE Rule_T3a(VER,VOLUME,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_T3a
!***REFER TO DCUTET
!***REVISION DATE  970324   (YYMMDD)
!***REVISION DATE  990528   (YYMMDD)  (F conversion)
!***PURPOSE  To compute basic integration rule values and
!            corresponding error estimates.
!***DESCRIPTION Rule_T3a computes basic integration rule values
!            for a vector of integrands over a tetrahedron.
!            Rule_T3a also computes estimates for the errors by
!            using several null rule approximations.
!   ON ENTRY
!
!   VER    Real array of dimension (3,4).
!          The coordinates of the vertices of the tetrahedron.
!          vertex i -> ( ver(1,i),ver(2,i),ver(3,i) )
!   NUMFUN Integer.
!          Number of components of the vector integrand.
!   Integrand Externally declared subroutine for computing
!            all components of the integrand at the given
!            evaluation point.
!            It must have parameters (X)
!            Input parameters:
!              X(1)   The x-coordinate of the evaluation point.
!              X(2)   The y-coordinate of the evaluation point.
!              X(3)   The z-coordinate of the evaluation point.
!
!   ON RETURN
!
!   BASVAL Real array of dimension NUMFUN.
!          The values for the basic rule for each component
!          of the integrand.
!   RGNERR Real array of dimension NUMFUN.
!          The error estimates for each component of the integrand.
!   NUM    Integer
!          The number of function evaluations used.
!
!***REFERENCES M. Beckers and A. Haegemans,
!              The construction of cubature formula for the tetrahedron
!              Report TW128, K.U. Leuven (1990).
!***ROUTINES CALLED
!                   OrbT3_Sum,Integrand
!***END PROLOGUE Rule_T3a
!
!   Parameters
!
!   ORBITS Integer
!          The number of orbits of the cubature formula and null rules
!   CRIVAL Real
!          The decision to choose the optimistic part of the error
!          estimator is based on CRIVAL
!   FACMED Real
!          FACMED is the safety coefficient used in the non-optimistic
!          part of the error estimator. FACMED is related to CRIVAL
!          and FACOPT.
!   FACOPT Real
!          FACOPT is the safety coefficient used in the optimistic part
!          of the error estimator.
!   K      Integer array of dimension (0:3) that contains the structure
!          parameters. K(I) = number of orbits of type I.
!   TYPE1  Real array of dimension (K(1)).
!          Contains the first homogeneous coordinate of the generators
!          of type 1
!   TYPE2  Real array of dimension (K(2)).
!          Contains the first homogeneous coordinate of the generators
!          of type 2
!   TYPE3  Real array of dimension (2,K(2)).
!          Contains the first two homogeneous coordinates of
!          the generators of type 3.
!   WEIGHT Real array of dimension (9,ORBITS).
!          The weights of the cubature formula and the null rules.
!          WEIGHT(1,1) ,..., WEIGHT(1,ORBITS) are the weights of the
!                cubature formula
!          WEIGHT(I,1) ,..., WEIGHT(I,ORBITS) for I > 1, are the weights
!                of the null rules
!
!
!   Global variables.
!
      INTEGER, INTENT(IN)                         :: NUMFUN
      INTEGER, INTENT(OUT)                        :: NUM
      REAL(kind=stnd), INTENT(IN)                 :: VOLUME
      REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
      REAL(kind=stnd), DIMENSION(:), INTENT(OUT)  :: BASVAL, RGNERR
      INTERFACE
         FUNCTION Integrand(NUMFUN,X) RESULT(Value)
            USE Precision_Model
            INTEGER, INTENT(IN) :: NUMFUN
            REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
            REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
         END FUNCTION Integrand
      END INTERFACE
!
!   Constants
!
      INTEGER, PARAMETER :: ORBITS = 7
      REAL(kind=stnd), PARAMETER:: CRIVAL=0.5_stnd,         &
                                   FACMED=5,                &
                                   FACOPT=FACMED/CRIVAL,    &
                                   TRES=50*EPSILON(crival)
!
!  Cubature formula of degree 8 with 43 points
!
      INTEGER, DIMENSION(0:3), PARAMETER ::                         &
              K = (/1,3,1,2/)         ! Rule structure parameters
!
!  Information for the generators
!
      REAL(kind=stnd), DIMENSION(1:3), PARAMETER ::                 &
              TYPE1 = (/ 0.379510205167980387748057300876_stnd,     &
                         0.753689235068359830728182577696_stnd,     &
                         0.982654148484406008240470085259_stnd/)
      REAL(kind=stnd), DIMENSION(1:1), PARAMETER ::                 &
              TYPE2 = (/ 0.449467259981105775574375471447_stnd/)
      REAL(kind=stnd), DIMENSION(1:2,1:2), PARAMETER ::             &
              TYPE3 = RESHAPE( SOURCE=                              &
                   (/ 0.506227344977843677082264893876_stnd,        &
                      0.356395827885340437169173969841E-1_stnd,     &
                      0.736298458958971696943019005441_stnd,        &
                      0.190486041934633455699433285302_stnd/),      &
                   SHAPE=(/2,2/), ORDER=(/1,2/) )
!
!  Weights of the cubature formula
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
           W1 = (/                                                  &
          -0.123001131951839495043519102752_stnd,                   &
           0.855018349372014074906384482699E-1_stnd,                &
           0.118021998788034059253768205083E-1_stnd,                &
           0.101900465455732427902646736855E-2_stnd,                &
           0.274781029468036908044610867719E-1_stnd,                &
           0.342269148520915110408153517904E-1_stnd,                &
           0.128431148469725555789001180031E-1_stnd/)
!
!  Weights of the null rule of degree 5
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
           W2 = (/                                                  &
           0.211921237628032658308230999090_stnd,                   &
          -0.660207516445726284649283745987E-1_stnd,                &
           0.225058824086711710443385047042E-1_stnd,                &
          -0.375962972067425589765730699401E-3_stnd,                &
           0.710066020561055159657284834784E-2_stnd,                &
           0.156515256061747694921427149028E-2_stnd,                &
          -0.814530839643584660306807872526E-2_stnd/)
!
!  Weights of null rule of degree 4
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
           W3 = (/                                                  &
          -0.508105488137100551376844924797E-1_stnd,                &
           0.104596681151665328209751420525E-1_stnd,                &
           0.927471438532788763594989973184E-1_stnd,                &
           0.210489990008917994323967321174E-2_stnd,                &
           0.379184172251962722213408547663E-1_stnd,                &
          -0.111747242913563605790923001557E-1_stnd,                &
          -0.386541758762774673113423570465E-1_stnd/)
!
!  Weights of first null rule of degree 3
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
           W4 = (/                                                  &
          -0.775992773232808462404390159802E-1_stnd,                &
          -0.527453289659022924847298408064E-1_stnd,                &
           0.145876238555932704488677626554E-1_stnd,                &
           0.739374873393616192857532718429E-2_stnd,                &
          -0.374618791364332892611678523428E-1_stnd,                &
           0.538502846550653076078817013885E-1_stnd,                &
          -0.183980865177843057548322735665E-1_stnd/)
!
!  Weights of second null rule of degree 3
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
           W5 = (/                                                  &
           0.181767621501470154602720474731E-1_stnd,                &
           0.179938831310058580533178529022E-1_stnd,                &
           0.713210362750414891598257378898E-1_stnd,                &
          -0.443935688958258805893448212636E-1_stnd,                &
          -0.657639036547720234169662790056E-1_stnd,                &
          -0.101551807522541414699808460583E-1_stnd,                &
           0.265486188970540796821750584204E-1_stnd/)
!
!  Weights of null rule of degree 2
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
           W6 = (/                                                  &
          -0.867629853722843888927184699428E-1_stnd,                &
          -0.715881271235661902772072127812E-1_stnd,                &
           0.886720767790426261677273459523E-2_stnd,                &
          -0.577885573028655167063092577589E-1_stnd,                &
           0.430310167581202031805055255554E-1_stnd,                &
          -0.606467834856775537069463817445E-2_stnd,                &
           0.319492443333738343104163265406E-1_stnd/)
!
!   Weights of null rule of degree 1
!
      REAL(kind=stnd), DIMENSION(1:ORBITS), PARAMETER ::            &
           W7 = (/                                                  &
           0.510374015624925451319499382594E-1_stnd,                &
           0.463998830432033721597269299429E-1_stnd,                &
          -0.191086148397852799983451475821E-1_stnd,                &
          -0.973768821003670776204287367278E-1_stnd,                &
           0.180352562073914141268335496511E-1_stnd,                &
           0.277129527093489643801598303110E-1_stnd,                &
          -0.176218263109360550515567818653E-1_stnd/)
!
      REAL(kind=stnd), DIMENSION(1:7,1:ORBITS), PARAMETER ::        &
           WEIGHT =  RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7/),    &
                            SHAPE=(/7,ORBITS/), ORDER=(/2,1/) )
!
!   Local variables.
!
      INTEGER :: J,NR,P,GENTYPE
      REAL(kind=stnd):: NOISE,DEG4,DEG3,DEG1,R2,R1,R
      REAL(kind=stnd), DIMENSION(NUMFUN) :: SUMVAL
      REAL(kind=stnd), DIMENSION(NUMFUN,6) :: NullRule
      REAL(kind=stnd), DIMENSION(3) :: Z
!
!***FIRST EXECUTABLE STATEMENT Rule_T3a
!
!  The number of points used by the cubature formula is
!     NUM    = K(0) + 4*K(1) + 6*K(2) + 12*K(3) = 43
      NUM = 43
!
!  Initialise BASVAL and NullRule
!
      BASVAL = 0
      NullRule = 0
!
!  Compute contributions from orbits with 1, 4, 6 and 12  points
!
      P = 1
      DO GENTYPE = 0,3
          DO NR = 1,K(GENTYPE)
              SELECT CASE (GENTYPE)
              CASE (1) !       Generator ( z(1) , z(2), z(2) , z(2) )
                  Z(1) = TYPE1(NR)
                  Z(2) = (1-Z(1))/3
              CASE (2) !       Generator ( z(1) , z(1), z(2) , z(2) )
                  Z(1) = TYPE2(NR)
                  Z(2) = (1-2*Z(1))/2
              CASE (3) !       Generator ( z(1) , z(2), z(3) , z(3) )
                  Z(1:2) = TYPE3(1:2,NR)
                  Z(3) = (1-Z(1)-Z(2))/2
              END SELECT
              CALL OrbT3_Sum(GENTYPE,Z,VER,NUMFUN,Integrand,SUMVAL)
              BASVAL = BASVAL + WEIGHT(1,P)*SUMVAL
              DO J = 1,NUMFUN
                 NullRule(J,1:6) = NullRule(J,1:6) + WEIGHT(2:7,P)*SUMVAL(J)
              END DO
              P = P + 1
          END DO
      END DO
!
!  Compute error estimates
!
      DO J = 1,NUMFUN
          NOISE = ABS(BASVAL(J))*TRES
          DEG4 = SQRT(NullRule(J,1)**2+NullRule(J,2)**2)
          DEG3 = SQRT(NullRule(J,3)**2+NullRule(J,4)**2)
          IF (DEG4 <= NOISE) THEN
              RGNERR(J) = NOISE
          ELSE
              DEG1 = SQRT(NullRule(J,5)**2+NullRule(J,6)**2)
              IF (DEG3 /= 0) THEN
                                    R1 = (DEG4/DEG3)**2
                             ELSE
                                    R1 = 1
              END IF
              IF (DEG1 /= 0) THEN
                                    R2 = DEG3/DEG1
                             ELSE
                                    R2 = 1
              END IF
              R = MAX(R1,R2)
              IF (R >= CRIVAL) THEN
                                    RGNERR(J) = FACMED*R*DEG4
                               ELSE
                                    RGNERR(J) = FACOPT*(R**2)*DEG4
              END IF
              RGNERR(J) = MAX(NOISE,RGNERR(J))
          END IF
          RGNERR(J) = VOLUME*RGNERR(J)
          BASVAL(J) = VOLUME*BASVAL(J)
      END DO
      RETURN
      END SUBROUTINE Rule_T3a

      SUBROUTINE OrbT3_Sum(GENTYPE,GENER,VER,NUMFUN,Integrand,SUMVAL)
!***BEGIN PROLOGUE OrbT3_Sum
!***PURPOSE  To compute the sum of function values over all points
!            of an orbit.
!***DESCRIPTION
!   ON ENTRY
!
!   GENTYPE Integer
!          The type of the orbit.
!   GENER  Integer array of dimension (3).
!          The generator for the orbit in homogeneous coordinates.
!   VER    Real array of dimension (3,4).
!          The coordinates of the vertices of the tetrahedron.
!          vertex i -> ( ver(1,i),ver(2,i),ver(3,i) )
!   NUMFUN Integer.
!          Number of components of the vector integrand.
!   Integrand Externally declared subroutine for computing
!            all components of the integrand at the given
!            evaluation point.
!            It must have parameters (DIM,X,NUMFUN,FUNVLS)
!            Input parameters:
!              DIM = 3
!              X(1)   The x-coordinate of the evaluation point.
!              X(2)   The y-coordinate of the evaluation point.
!              X(3)   The z-coordinate of the evaluation point.
!              NUMFUN Integer that defines the number of
!                     components of the vector integrand.
!            Output parameter:
!              FUNVLS Real array of dimension NUMFUN
!                     that defines NUMFUN components of the integrand.

!   ON RETURN
!
!   SUMVAL Real array of dimension (NUMFUN).
!          The sum of function values over all points
!          of the given orbit.
!
!***END PROLOGUE  OrbT3_Sum
!
!  Global variables
!
      INTEGER, INTENT(IN) :: NUMFUN,GENTYPE
      REAL(kind=stnd), DIMENSION(:), INTENT(IN)   :: GENER
      REAL(kind=stnd), DIMENSION(:), INTENT(OUT)  :: SUMVAL
      REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
      INTERFACE
         FUNCTION Integrand(NUMFUN,X) RESULT(Value)
            USE Precision_Model
            INTEGER, INTENT(IN) :: NUMFUN
            REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
            REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
         END FUNCTION Integrand
      END INTERFACE
!
!  Local variables
!
      INTEGER ::  J,NUMBER
      REAL(kind=stnd):: Z1,Z2,Z3
      REAL(kind=stnd), DIMENSION(3,12) :: X
      REAL(kind=stnd), DIMENSION(NUMFUN) :: WORK
!***FIRST EXECUTABLE STATEMENT  OrbT3_Sum
      SELECT CASE (GENTYPE)
!
!  Generator with homogeneous coordinates (1/4,1/4,1/4,1/4)
!
      CASE (0)
          NUMBER = 1
          X(:,1) = SUM( VER, DIM=2 )/4
!
!  Generator with homogeneous coordinates (z1,z2,z2,z2)
!
      CASE (1)
          NUMBER = 4
          Z1 = GENER(1)
          Z2 = GENER(2)
          X(:,1) = Z1*VER(:,1) + Z2* (VER(:,2)+VER(:,3)+VER(:,4))
          X(:,2) = Z1*VER(:,2) + Z2* (VER(:,1)+VER(:,3)+VER(:,4))
          X(:,3) = Z1*VER(:,3) + Z2* (VER(:,2)+VER(:,1)+VER(:,4))
          X(:,4) = Z1*VER(:,4) + Z2* (VER(:,2)+VER(:,3)+VER(:,1))
!
!  Generator with homogeneous coordinates (z1,z1,z2,z2)
!
      CASE (2)
        NUMBER = 6
        Z1 = GENER(1)
        Z2 = GENER(2)
        X(:,1) = Z1* (VER(:,1)+VER(:,2)) + Z2* (VER(:,3)+VER(:,4))
        X(:,2) = Z1* (VER(:,1)+VER(:,3)) + Z2* (VER(:,2)+VER(:,4))
        X(:,3) = Z1* (VER(:,1)+VER(:,4)) + Z2* (VER(:,3)+VER(:,2))
        X(:,4) = Z1* (VER(:,2)+VER(:,3)) + Z2* (VER(:,1)+VER(:,4))
        X(:,5) = Z1* (VER(:,2)+VER(:,4)) + Z2* (VER(:,1)+VER(:,3))
        X(:,6) = Z1* (VER(:,3)+VER(:,4)) + Z2* (VER(:,1)+VER(:,2))
!
!  Generator with homogeneous coordinates (z1,z2,z3,z3)
!
      CASE (3)
        NUMBER = 12
        Z1 = GENER(1)
        Z2 = GENER(2)
        Z3 = GENER(3)
        X(:,1) = Z1*VER(:,1) + Z2*VER(:,2) + Z3* (VER(:,3)+VER(:,4))
        X(:,2) = Z1*VER(:,1) + Z2*VER(:,3) + Z3* (VER(:,2)+VER(:,4))
        X(:,3) = Z1*VER(:,1) + Z2*VER(:,4) + Z3* (VER(:,2)+VER(:,3))
        X(:,4) = Z1*VER(:,2) + Z2*VER(:,1) + Z3* (VER(:,3)+VER(:,4))
        X(:,5) = Z1*VER(:,2) + Z2*VER(:,3) + Z3* (VER(:,1)+VER(:,4))
        X(:,6) = Z1*VER(:,2) + Z2*VER(:,4) + Z3* (VER(:,1)+VER(:,3))
        X(:,7) = Z1*VER(:,3) + Z2*VER(:,1) + Z3* (VER(:,2)+VER(:,4))
        X(:,8) = Z1*VER(:,3) + Z2*VER(:,2) + Z3* (VER(:,1)+VER(:,4))
        X(:,9) = Z1*VER(:,3) + Z2*VER(:,4) + Z3* (VER(:,1)+VER(:,2))
        X(:,10) = Z1*VER(:,4) + Z2*VER(:,1) + Z3* (VER(:,2)+VER(:,3))
        X(:,11) = Z1*VER(:,4) + Z2*VER(:,2) + Z3* (VER(:,1)+VER(:,3))
        X(:,12) = Z1*VER(:,4) + Z2*VER(:,3) + Z3* (VER(:,1)+VER(:,2))
      END SELECT
      SUMVAL = Integrand(NUMFUN,X(:,1))
      DO J = 2,NUMBER
         WORK = Integrand(NUMFUN,X(:,J))
         SUMVAL(1:NUMFUN) = SUMVAL(1:NUMFUN) + WORK(1:NUMFUN)
      END DO
      RETURN
      END SUBROUTINE OrbT3_Sum

END MODULE CubatureRule_T3


      subroutine initgr(nowcrp)
c
c     + + + PURPOSE + + +
c     Called to initialize perennial growth after plant has been frozen
c     and is starting to grow.  Estimates the vegetative dry matter at
c     maturity (VDMT).
c
c     Called from PTGRP, INIT1
c     Author(s):  Alberts, Ghiddey, Ferris, Arnold
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP Version 92.25.
c     Date recoded: 08/25/92.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pntype.inc'
      include 'pmxpln.inc'
      include 'pmxcrp.inc'
      include 'pmxres.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
      include 'pmxcut.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer nowcrp
c
c     + + + ARGUMENT DEFINITIONS + + +
c     nowcrp - the current crop
c
c     + + + COMMON BLOCKS + + +
      include 'ccover.inc'
c       read: cancov(mxplan)
c      write: canhgt(mxplan)
c
      include 'ccrpvr2.inc'
c     modify: vdmt(mxplan)
c
      include 'ccrpvr3.inc'
c       read: hmax(ntype), gddmaxi(ntype), bb(ntype), bbb(ntype),
c             xmxlai(ntype)
c     modify: sumgdd(mxplan)
c
      include 'ccrpprm.inc'
c       read: itype(mxcrop,mxplan)
c
      include 'ccrpout.inc'
c     modify: lai(mxplan)
c
      include 'cperen.inc'
c       read: imngmt(mxcrop,mxplan)
c
      include 'cstruc.inc'
c       read: iplane
c
c     + + + END SPECIFICATIONS + + +
c
c
c ---- Compute vegetative dry matter (VDMT), from canopy cover (CANCOV).
      vdmt(iplane) = log(1.0-cancov(iplane)) / (-
     1    bb(itype(nowcrp,iplane)))
      if (vdmt(iplane).lt.0.) vdmt(iplane) = 0.0
c
c     ---- Compute canopy height (CANHGT), from vegetative dry matter (VDMT)
c     and plant height at maturity (HMAX).
      canhgt(iplane) = (1.-exp(-bbb(itype(nowcrp,iplane))*vdmt(iplane)))
     1    * hmax(itype(nowcrp,iplane))
c
c     ---- Compute leaf area index (LAI), from maximum leaf area index
c     (XMXLAI) and vegetative dry matter (VDMT).
c     ** CROPLAND ANNUALS **
      if (imngmt(nowcrp,iplane).eq.1) then
        lai(iplane) = (xmxlai(itype(nowcrp,iplane))*vdmt(iplane)) / (
     1      vdmt(iplane)+0.5512*exp(-6.8*vdmt(iplane)))
c
c     ** PERENNIALS OR RANGELAND **
      else
        lai(iplane) = (xmxlai(itype(nowcrp,iplane))*vdmt(iplane)) / (
     1      vdmt(iplane)+0.2756*exp(-13.6*vdmt(iplane)))
      end if
c
c     ---- Compute cumulative growing degree days (SUMGDD), from growing
c     degree days at maturity (GDDMAX), leaf area index (LAI), and
c     maximum leaf area index (XMXLAI).
      sumgdd(iplane) = gddmax(itype(nowcrp,iplane)) * lai(iplane) /
     1    xmxlai(itype(nowcrp,iplane))
c
c     Handle the case of a winter annual which has relatively low
c     cover -- so low that calculation of sumgdd is below value of
c     the critical value of growing degree days for emergence (CRIT).
c
      if ((jdharv(nowcrp,iplane).lt.jdplt(nowcrp,iplane)).and.(
     1    sumgdd(iplane).lt.crit(itype(nowcrp,iplane))))
     1    sumgdd(iplane) = crit(itype(nowcrp,iplane)) + 0.1
c
      return
      end


c
c  subroutine calcC(C,F)
c  subroutine calcB(B,F)
c
c  subroutine pushfwrd_s(B,F,C)
c  subroutine pushfwrd2D_s(B,F,F33,C)
c
c  subroutine pushfwrd_4(cc,F,C)
c  subroutine pushfwrd2D_4(cc,F,F33,C)
c
c  subroutine taub2sigccPart1(stre,cc,b,dtaudb,detF)
c  subroutine taub2sigccPart2(stre,cc)
c
c  subroutine computeElasticResponse(S,dSdC,dSdCp,C,invC,diCdC,Cp,invCp,diCpdCp,d)
c
c  subroutine smallStrainTensor(eps,F)
c
c
c
c

c=============================================================================
c
c     CALCULATE THE RIGHT CAUCHY-GREEN TENSOR
c
      subroutine calcC(C,F)
c-----------------------------------------------------------------------------
      implicit none
      double precision C(*), F(3,*)

      C(1) = F(1,1)*F(1,1) + F(2,1)*F(2,1) + F(3,1)*F(3,1)
      C(2) = F(1,2)*F(1,2) + F(2,2)*F(2,2) + F(3,2)*F(3,2)
      C(3) = F(1,3)*F(1,3) + F(2,3)*F(2,3) + F(3,3)*F(3,3)
      C(4) = F(1,1)*F(1,2) + F(2,1)*F(2,2) + F(3,1)*F(3,2)
      C(5) = F(1,2)*F(1,3) + F(2,2)*F(2,3) + F(3,2)*F(3,3)
      C(6) = F(1,3)*F(1,1) + F(2,3)*F(2,1) + F(3,3)*F(3,1)

      return
      end

c=============================================================================
c
c     CALCULATE THE LEFT CAUCHY-GREEN TENSOR
c
      subroutine calcB(b,F)
c-----------------------------------------------------------------------------
      implicit none
      double precision b(*), F(3,*)

      b(1) = F(1,1)*F(1,1) + F(1,2)*F(1,2) + F(1,3)*F(1,3)
      b(2) = F(2,1)*F(2,1) + F(2,2)*F(2,2) + F(2,3)*F(2,3)
      b(3) = F(3,1)*F(3,1) + F(3,2)*F(3,2) + F(3,3)*F(3,3)
      b(4) = F(1,1)*F(2,1) + F(1,2)*F(2,2) + F(1,3)*F(2,3)
      b(5) = F(2,1)*F(3,1) + F(2,2)*F(3,2) + F(2,3)*F(3,3)
      b(6) = F(3,1)*F(1,1) + F(3,2)*F(1,2) + F(3,3)*F(1,3)

      return
      end

c=============================================================================
c
c     PUSHFORWARD OF SYMMETRIC SECOND ORDER TENSOR
c
      subroutine pushfwrd_s(B,F,C)
c-----------------------------------------------------------------------------
      implicit none
      double precision B(*), F(3,*), C(*), H(3,3)

      call mult_u_us_p (H,F,C)

      call mult_s_uuT_p(B,H,F)

      return
      end

c=============================================================================
c
c     PUSHFORWARD OF SYMMETRIC SECOND ORDER TENSOR IN 2D
c
      subroutine pushfwrd2D_s(B,F,F33,C)
c-----------------------------------------------------------------------------
      implicit none
      double precision B(*), F(2,*), F33, C(*), H(2,2)

      H(1,1) = F(1,1)*C(1) + F(1,2)*C(3)
      H(1,2) = F(1,1)*C(3) + F(1,2)*C(2)
      H(2,1) = F(2,1)*C(1) + F(2,2)*C(3)
      H(2,2) = F(2,1)*C(3) + F(2,2)*C(2)
      B(1)   = H(1,1)*F(1,1) + H(1,2)*F(1,2)
      B(2)   = H(2,1)*F(2,1) + H(2,2)*F(2,2)
      B(3)   = H(1,1)*F(2,1) + H(1,2)*F(2,2)
      B(4)   = C(4) * F33 * F33
      return
      end

c=============================================================================
c
c     PUSHFORWARD OF FOURTH ORDER TENSOR (format: 6x6 matrix)
c
      subroutine pushfwrd_4(cc,F,C)
c-----------------------------------------------------------------------------
      implicit none
      double precision cc(6,*), F(3,*), C(6,*), fact, H(6,6)

      integer I, J, K, L, ii, jj, kk, ll,
     *        indx1(2,6), indx2(3,3), A, B, rw, cl

      data indx1 / 1, 1, 2, 2, 3, 3, 1, 2, 2, 3, 3, 1 /

      data indx2 / 1, 4, 6,
     *             4, 2, 5,
     *             6, 5, 3 /
c
c  this subroutine performs 756 multiplications !!!!!!  avoid using it !!!
c
      call pzero(H,36)
      do rw=1, 6
        ii = indx1(1,rw)
        jj = indx1(2,rw)
        do I=1, 3
          do J=1, 3
            A = indx2(I,J)
            fact = F(ii,I) * F(jj,J) ! x 54
            do cl=1, 6
              H(rw,cl) = H(rw,cl) + fact * C(A,cl) ! x 324
            enddo
          enddo
        enddo
      enddo

      call pzero(cc,36)
      do cl=1, 6
        kk = indx1(1,cl)
        ll = indx1(2,cl)
        do K=1, 3
          do L=1, 3
            B = indx2(K,L)
            fact = F(kk,K) * F(ll,L) ! x 54
            do rw=1, 6
              cc(rw,cl) = cc(rw,cl) + fact * H(rw,B) ! x 324
            enddo
          enddo
        enddo
      enddo

      return
      end

c=============================================================================
c
c     PUSHFORWARD OF FOURTH ORDER TENSOR IN 2D (format: 4x4 matrix)
c
      subroutine pushfwrd2D_4(cc,F,F33,C)
c-----------------------------------------------------------------------------
      implicit none
      double precision cc(4,*), F(2,*), F33, C(4,*),
     *                 fact, H(3,3), fact1, F332

      integer          I, J, K, L, ii, jj, kk, ll,
     *                 indx1(2,3), indx2(2,2), A, B, rw, cl

      data indx1 / 1, 1, 2, 2, 1, 2 /

      data indx2 / 1, 3,
     *             3, 2 /

c
c  this subroutine performs 159 multiplications !!!!!!  avoid using it !!!
c
      call pzero(H,9)
      do rw=1, 3
        ii = indx1(1,rw)
        jj = indx1(2,rw)
        do I=1, 2
          do J=1, 2
            A = indx2(I,J)
            fact = F(ii,I) * F(jj,J) ! x 12
            do cl=1, 3
              H(rw,cl) = H(rw,cl) + fact * C(A,cl) ! x 36
            enddo
          enddo
        enddo
      enddo

      call pzero(cc,16)
      do cl=1, 3
        kk = indx1(1,cl)
        ll = indx1(2,cl)
        do K=1, 2
          do L=1, 2
            B = indx2(K,L)
            fact = F(kk,K) * F(ll,L) ! x 12
            do rw=1, 3
              cc(rw,cl) = cc(rw,cl) + fact * H(rw,B) ! x 36
            enddo
          enddo
        enddo
      enddo

      F332 = F33 * F33 ! x 1

      do rw=1, 3
        ii = indx1(1,rw)
        jj = indx1(2,rw)
        do I=1, 2
          fact1 = F332 * F(ii,I) ! x 6
          do J=1, 2
            A = indx2(I,J)
            cc(rw,4) = cc(rw,4) + fact1 * F(jj,J) * C(A,4) ! x 12 + 12
          enddo
        enddo
      enddo

      do cl=1, 3
        kk = indx1(1,cl)
        ll = indx1(2,cl)
        do K=1, 2
          fact1 = F332 * F(kk,K) ! x 6
          do L=1, 2
            B = indx2(K,L)
c           if (cl.eq.3) write(*,'(10(i3))') cl, kk, K, ll, L, B
            cc(4,cl) = cc(4,cl) + fact1 * F(ll,L) * C(4,B) ! x 12 + 12
          enddo
        enddo
      enddo

      cc(4,4) = C(4,4) * F332 * F332 ! x 2

      return
      end
c=============================================================================
c
c     CALCULATION OF CAUCHY STRESS AND SPATIAL TANGENT
c
c     input:  tau    - Kirchhoff stress
c             b      - left Cauchy-Green tensor b = F Ft
c             dtaudb - derivative of tau with respect to b
c             detF   - determinant of F
c
c     output: sig    - Cauchy stress sigma
c             cc     - spatial tangent tensor !!without geometrical part!!
c
      subroutine taub2sigccPart1(sig,cc,tau,dtaudb,b,detF)
c-----------------------------------------------------------------------------
      implicit none

      double precision sig(6), cc(6,6), tau(6), dtaudb(6,6), b(6), detF,
     *                 fact, r1d2

      r1d2 = .5d0

      fact = 1.d0 / detF

      call set_s_af(sig,tau,fact)

      fact = fact + fact

      call mult_4_4s_af(cc,dtaudb,b,fact)

      return

      end

c=============================================================================
c
c     CALCULATION OF CAUCHY STRESS AND SPATIAL TANGENT
c
c     input:  sig - Cauchy stress
c             cc  - spatial tangent without geometrical part
c
c     output: cc  - complete spatial tangent tensor
c
      subroutine taub2sigccPart2(sig,cc)
c-----------------------------------------------------------------------------
      implicit none

      double precision sig(6), cc(6,6),
     *                 r1d2

      r1d2 = .5d0

      cc(1,1) = cc(1,1) - sig(1) - sig(1)
      cc(1,4) = cc(1,4) - sig(4)
      cc(1,6) = cc(1,6) - sig(6)
      cc(2,2) = cc(2,2) - sig(2) - sig(2)
      cc(2,4) = cc(2,4) - sig(4)
      cc(2,5) = cc(2,5) - sig(5)
      cc(3,3) = cc(3,3) - sig(3) - sig(3)
      cc(3,5) = cc(3,5) - sig(5)
      cc(3,6) = cc(3,6) - sig(6)
      cc(4,1) = cc(4,1) - sig(4)
      cc(4,2) = cc(4,2) - sig(4)
      cc(4,4) = cc(4,4) -(sig(1)+sig(2)) * r1d2
      cc(4,5) = cc(4,5) - sig(6) * r1d2
      cc(4,6) = cc(4,6) - sig(5) * r1d2
      cc(5,2) = cc(5,2) - sig(5)
      cc(5,3) = cc(5,3) - sig(5)
      cc(5,4) = cc(5,4) - sig(6) * r1d2
      cc(5,5) = cc(5,5) -(sig(2)+sig(3)) * r1d2
      cc(5,6) = cc(5,6) - sig(4) * r1d2
      cc(6,1) = cc(6,1) - sig(6)
      cc(6,3) = cc(6,3) - sig(6)
      cc(6,4) = cc(6,4) - sig(5) * r1d2
      cc(6,5) = cc(6,5) - sig(4) * r1d2
      cc(6,6) = cc(6,6) -(sig(3)+sig(1)) * r1d2

      return

      end

c=============================================================================
c
c     COMPUTATION OF ELASTIC MATERIAL RESPONSE
c     BASED ON MULTIPLICATIVE SPLIT OF DEFORMATION GRADIENT
c     INTO ELASTIC AND INELASTIC PARTS
c
c     F = Fe Fp
c
      subroutine computeElasticResponse(S,dSdC,dSdCp,
     *                                  C,invC,diCdC,Cp,invCp,diCpdCp,
     *                                  K,matData,typ)
c
c     input: tensors C, invC, dinvC/dC, Cp, invCp, dinvCp/dCp
c            bulk modulus K, shear stiffness in matData, elasticity typ
c
c     output: S, dSdC, dSdCp
c
c-----------------------------------------------------------------------------
      implicit none
      integer          typ,
     *                 i, l, round
      double precision S(6), dSdC(6,6), dSdCp(6,6), C(6), invC(6),
     *                 diCdC(6,6), Cp(6), invCp(6), diCpdCp(6,6),
     *                 K, matData(*),
     *                 h4(6,6), h2(9), fact, srC(6), isrC(6), dsrC(6,6),
     *                 disrC(6,6), h22(9), h23(9), h42(6,6), h43(6,6),
     *                 mu, Lamb, J2, J, muJm2d3, p, pJ, trp,
     *                 det_s, traceAB_ss,
     *                 r1d3, r1d2, r2d3, r5d6, r1, r4d3

      data r1d2, r1 / 0.5d0, 1.d0 /
      r1d3 = 1.d0 / 3.d0
      r2d3 = r1d3 + r1d3
      r4d3 = r2d3 + r2d3
      r5d6 = 2.5d0 * r1d3

      goto (10,20,30,40), typ

c-----------------------------------------------------------------------------
c     (1) Neo-Hooke
c
c    sig = mu Je^(-5/3) dev(Be) + K (Je-1)
c
c   -> S = mu Je^(-2/3) (invCp - tr(C invCp)/3 invC) + K Je(Je-1) invC
c
c    Je = sqrt(det(C)/det(Cp))
c
c   Wriggers, page 46  XXXXXXXXXXXXXXXXXXXXX???????XXXXXXXXX
c
c-----------------------------------------------------------------------------
 10   continue

      mu      = matData(1)

      J2      = det_s(C) / det_s(Cp)
      muJm2d3 = J2**(-r1d3) * mu
      pJ      = r1d2 * K * (J2 - r1)
      trp     = - muJm2d3 * r1d3 * traceAB_ss(C,invCp) + pJ

c     S
      call set_s_f     (S,invCp,muJm2d3)
      call set_s_af    (S,invC, trp)

c      do i=1, 3
c        S(i) = S(i) + muJm2d3
c      enddo

c     dSdC
      fact = - r1d3
      call set_s_f     (h2,S,fact)
      fact = r2d3 * K * J2 - K / 6.d0
      call set_s_af  (h2,invC,fact)
      call mult_4_ss_p (dSdC,h2,invC)
      fact = - r1d3 * muJm2d3
      call mult_4_ss_af(dSdC,invC,invCp,fact)
      call set_4_af    (dSdC,diCdC,trp)

c     dSdCp
      call mult_4_ss_m (dSdCp,h2,invCp)
      call mult_4_ss_f (h4,invC,C,fact)
      call unit_4_af   (h4,muJm2d3)
      call mult_4_44_ap(dSdCp,h4,diCpdCp)

      return

c-----------------------------------------------------------------------------
c     (2) St. Venant-Kirchhoff
c-----------------------------------------------------------------------------
 20   continue

      mu      = matData(1)
      Lamb    = K - r2d3 * mu

      call mult_u_ss_p (h2,invCp,C)
      call mult_s_us_f (S,h2,invCp,mu)
      fact = - mu
      call set_s_af    (S,invCp,fact)
      fact = Lamb * 0.5d0 * (h2(1)+h2(5)+h2(9)-3.d0)
      call set_s_af    (S,invC,fact)

      call diff_ATA_f  (dSdC,invCp,mu)
      call set_4_af    (dSdC,diCdC,fact)
      fact = Lamb * 0.5d0
      call mult_4_ss_af(dSdC,invC,invCp,fact)

      call diff_UT_f   (h4,h2,mu)
      call transpose_r (h2)
      call diff_TU_af  (h4,h2,mu)
      fact = Lamb * 0.5d0
      call mult_4_ss_af(h4,invC,C,fact)
      call mult_4_44_p (dSdCp,h4,diCpdCp)
      fact = - mu
      call set_4_af    (dSdCp,diCpdCp,fact)

      return

c-----------------------------------------------------------------------------
c     (3) Hencky
c-----------------------------------------------------------------------------
 30   continue

c      write(*,*) "   Warning! this Hencky stuff may be dodgy!"

      mu = matData(1)

      call sqrt_s      (srC,dsrC,C)    ! -> srC, dsrC
      call inverse_s   (isrC,srC)      ! -> isrC
      call diff_ATA_m  (h4,isrC)       !
      call mult_4_44_p (disrC,h4,dsrC) ! -> disrC
      call inverse_s   (invCp,Cp)      ! -> iCp

      !call mult_s_ss_p (h2,isrC,isrC)
      !call set_s_am    (h2,invC)

      call mult_u_ss_p (h2,invCp,srC)  !
      call mult_s_su_p (h22,srC,h2)    !
      call log_s       (h23,h4,h22,10) ! -> h23 = log(srC invCp srC)
                                       ! -> h4  = d log(") d "
      call diff_TAT_p  (h42,h2)
      call mult_4_44_p (h43,h4,h42)
      call mult_4_44_p (h42,h43,dsrC)  ! -> h42 = d log(srC invCp srC) / d C

      call mult_u_ss_p (h2,h23,isrC)   ! -> h2  = log(srC invCp srC) isrC

      call mult_s_su_f (S,isrC,h2,mu)

      call diff_TAT_p  (h43,h2)
      call mult_4_44_f (dSdC,h43,disrC,mu)
      call diff_ATA_p  (h43,isrC)      ! -> h43 = d isrC T isrC / d T
      call mult_4_44_af(dSdC,h43,h42,mu)

      fact = - mu / 3.d0 * (h23(1)+h23(2)+h23(3))
     *        + K / 2.d0 * (det_s(C) - 1.d0)
      call set_s_af(S,invC,fact)

      call set_4_af    (dSdC,diCdC,fact)
      call unit_s_p    (h23)
      fact = - mu / 3.d0
      call mult_s_s4_f (h22,h23,h42,fact)
      fact =    K / 2.d0 * det_s(C)
      call set_s_af    (h22,invC,fact)
      call mult_4_ss_ap(dSdC,invC,h22)

      call set_4_f     (h42,h43,mu)
      call unit_s_p    (h2)
      fact = - mu / 3.d0
      call mult_4_ss_af(h42,invC,h2,fact)
      call mult_4_44_p (h43,h42,h4)
      call diff_ATA_p  (h42,srC)
      call mult_4_44_p (h4,h43,h42)
      call mult_4_44_p (dSdCp,h4,diCpdCp)

      return

c-----------------------------------------------------------------------------
c     (4) Ogden
c-----------------------------------------------------------------------------
 40   continue

      call prgError(1,"computeElasticResponse(contiMech.for)",
     *                "this has not yet been implemented!")

      return

      end
c=============================================================================
c
c     CALCULATION OF SMALL STRAIN TENSOR FROM DEFORMATION GRADIENT
c
      subroutine smallStrainTensor(eps,F)
c-----------------------------------------------------------------------------
      implicit none
      double precision eps(*), F(3,*), r1d2, r1

      data r1d2, r1 / 0.5d0, 1.d0 /

      eps(1) = F(1,1) - r1
      eps(2) = F(2,2) - r1
      eps(3) = F(3,3) - r1

      eps(4) = r1d2 * (F(1,2)+F(2,1))
      eps(5) = r1d2 * (F(2,3)+F(3,2))
      eps(6) = r1d2 * (F(3,1)+F(1,3))

      return

      end
c=============================================================================


FILE  5 = CARD, UNIT = READER, RECORD = 10, BUFFER = 2                  00000100
FILE  6 = LPA, UNIT = PRINTER, RECORD = 15, BUFFER = 2                  00000200
FILE  7 = X85, UNIT = TAPE, RECORD = 3, BUFFER = 2                      00000300
C                                                                       00000400
C     BMDX85 ---- NON-LINEAR LEAST SQUARES ANALYSIS CURVE FIT (FORTRAN) 00000500
C                                                                       00000600
C        SUBROUTINE FUN FOR TEST PROBLEM OF BMDX85                      00000700
      SUBROUTINE FUN(F,FP,P,X,NP);                                      00000800
      DIMENSION X(1),FP(NP),P(NP)                                       00000900
      NPP=NP-1                                                          00001000
C        LOG TRANSFORM ON EXP CURVE                                     00001100
      U=0.0                                                             00001200
      DO 10003 I=1,NPP,2                                                00001300
      J=I+1                                                             00001400
      FP(I)= EXP(P(J)|X(1))                                             00001500
10003 U=U + P(I) | FP(I)                                                00001600
      IF (U) 10004, 10004, 10005                                        00001700
10004 WRITE(6,10000) U,(P(I),I=1,NP),X(1)                               00001800
      WRITE(6,10000)                                                    00001900
10000 FORMAT(1P10E12.4)                                                 00002000
10005 F = ALOG(U)                                                       00002100
      U =1/U                                                            00002200
      DO 10002 I=1,NPP,2                                                00002300
      J=I+1                                                             00002400
      FP(I)=U|FP(I)                                                     00002500
10002 FP(J)=P(I)|X(1)|FP(I)                                             00002600
      RETURN                                                            00002700
      END                                                               00002800
C        SUBROUTINE STEP FOR BMDX85                  APRIL  4, 1966     00002900
      SUBROUTINE STEP(A,D,P,P0,P1,NP1,TOL)                              00003000
      DIMENSION A(NP1,NP1),V(100),D(100),IN(100),P0(100),P1(100),P(100) 00003100
      NP#NP1-1                                                          00003200
      DO 20 I#1,NP1                                                     00003300
      V(I)#SQRT(A(I,I))                                                 00003400
      DO 20 J#1,I                                                       00003500
 20   A(I,J)#A(I,J)/(V(I)*V(J))                                         00003600
      DO 2 I#1,NP                                                       00003700
 2    IN(I)#0                                                           00003800
 8    K#0                                                               00003900
      R#0.                                                              00004000
      DO 1 I#1,NP                                                       00004100
      IF(IN(I).NE.0 .OR. A(I,I).LE.TOL) GO TO 1                         00004200
      Q#A(NP1,I)*A(NP1,I)/A(I,I)                                        00004300
      IF(Q.LE.R) GO TO 1                                                00004400
      K#I                                                               00004500
      R#Q                                                               00004600
 1    CONTINUE                                                          00004700
      IF(K.EQ.0) GO TO 3                                                00004800
      C#-1.                                                             00004900
 4    DO 5 I#1,K                                                        00005000
      D(I)#A(K,I)                                                       00005100
 5    A(K,I)#0.                                                         00005200
      PP#D(K)                                                           00005300
      DO 6 I#K,NP1                                                      00005400
      D(I)#A(I,K)                                                       00005500
 6    A(I,K)#0.                                                         00005600
      D(K)#C                                                            00005700
      IN(K)#IN(K)&1                                                     00005800
      DO 7 I#1,NP1                                                      00005900
      Y#D(I)/PP                                                         00006000
      DO 7 J#1,I                                                        00006100
 7    A(I,J)#A(I,J)-D(J)*Y                                              00006200
      GO TO 8                                                           00006300
 3    R#1.                                                              00006400
      DO 9 I#1,NP                                                       00006500
      IF(IN(I).NE.1) GO TO 9                                            00006600
      D(I)#A(NP1,I)*V(NP1)/V(I)                                         00006700
      H#AMAX1((P0(I)-P(I))/D(I),(P1(I)-P(I))/D(I))                      00006800
      IF(H.GE.R) GO TO 9                                                00006900
      R#H                                                               00007000
      K#I                                                               00007100
 9    CONTINUE                                                          00007200
      C#1.                                                              00007300
      IF(R.LE.TOL) GO TO 4                                              00007400
      DO 10 I#1,NP                                                      00007500
      IF(IN(I).NE.1) GO TO 11                                           00007600
      D(I)#D(I)*R                                                       00007700
      DO 21 J#1,I                                                       00007800
      A(I,J)#-A(I,J)/(V(I)*V(J))                                        00007900
 21   A(J,I)#A(I,J)                                                     00008000
      GO TO 10                                                          00008100
 11   D(I)#0.                                                           00008200
      DO 22 J#1,I                                                       00008300
      A(I,J)#0.                                                         00008400
 22   A(J,I)#0.                                                         00008500
 10   CONTINUE                                                          00008600
      RETURN                                                            00008700
      END                                                               00008800
C        SUBROUTINE MINIZ FOR BMDX85                 APRIL  4, 1966     00008900
      SUBROUTINE MINIZ(X,A,P,NV,NC,NP1,TOL,EPS,EE,ND,MXIT,LLK,P0,P1,F,T)00009000
      DIMENSION A(NP1,NP1),X(NV,NC),P(100),FP(100),D(100),P0(100),P1(10000009100
     X),F(NC)                                                           00009200
      DIMENSION PP0(100)                                                00009300
      DATA BLANK,ERR,OR,ME,AN,SQU,ARE/1H ,6H    ER,6HROR   ,6H    ME,   00009400
     X6HAN    ,6H    SQ,6HUARE  /                                       00009500
      NP#NP1-1                                                          00009600
      MNAIL # 10                                                        00009700
      NAIL # 0                                                          00009800
      DO 557 I#1,NP                                                     00009900
 557  PP0(I)#P(I)                                                       00010000
      NP3#NP-2                                                          00010100
      EPS1#5.*EPS&1.                                                    00010200
      IF(NP.EQ.1) GO TO 191                                             00010300
      IF(NP.GE.10) GO TO 192                                            00010400
      WRITE (6,26) (P0(I),I#1,NP)                                       00010500
 26   FORMAT(10H1MINIMA   1P9E12.4)                                     00010600
      WRITE (6,27) (P1(I),I#1,NP)                                       00010700
 27   FORMAT(10H0MAXIMA   1P9E12.4)                                     00010800
      IF(NP.EQ.2) WRITE (6,177) ERR,OR                                  00010900
      IF(NP.NE.2) WRITE (6,177) (BLANK,BLANK,I#1,NP3),ERR,OR            00011000
 177  FORMAT(36H0ITERATION     PARAMETERS                   16A6)       00011100
      NP3#NP&1                                                          00011200
      WRITE (6,178) (BLANK,BLANK,I#1,NP3),ME,AN                         00011300
      WRITE (6,178) (BLANK,BLANK,I#1,NP3),SQU,ARE                       00011400
 178  FORMAT(22A6)                                                      00011500
 194  LLL#5                                                             00011600
      LIT#0                                                             00011700
      HU#NC                                                             00011800
      H#0.                                                              00011900
      LLLL#5                                                            00012000
      E0#1.E20                                                          00012100
      DO 556 I#1,NP                                                     00012200
 556  P(I)#PP0(I)                                                       00012300
      FNC#NC-NP                                                         00012400
 29   DO 85 I#1,NP1                                                     00012500
      DO 85 J#1,I                                                       00012600
 85   A(I,J)#0.                                                         00012700
      DO 1 L#1,NC                                                       00012800
C     CALL FUN(F(L),FP,X(1,L),P,LLK)                                    00012900
      CALL FUN(F(L),FP,P,X(1,L),NP)                                     00013000
      FP(NP1)#X(ND,L)-F(L)                                              00013100
      DO 1 I#1,NP1                                                      00013200
      DO 1 J#1,I                                                        00013300
 1    A(I,J)#A(I,J)&FP(I)*FP(J)                                         00013400
      EE#A(NP1,NP1)/FNC                                                 00013500
      IF(EE.LE.E0) GO TO 871                                            00013600
      NAIL#NAIL&1                                                       00013700
      IF(NAIL.GT.MNAIL) GO TO 871                                       00013800
      DO 872 I#1,NP                                                     00013900
      P(I)#PP0(I)&D(I)/2.                                               00014000
 872  D(I)#D(I)/2.                                                      00014100
      GO TO 29                                                          00014200
 871  IF(NP.LT.10) WRITE (6,174) LIT,NAIL,(P(I),I#1,NP),EE              00014300
 174  FORMAT(I6,1X,I2,1X,1P10E12.4)                                     00014400
      IF(NP.GE.10) WRITE (6,198) LIT,NAIL,EE,(P(I),I#1,NP)              00014500
 198  FORMAT(I6,1X,I2,1X,1P10E12.4/(22X,1P9E12.4))                      00014600
      NAIL#0                                                            00014700
 8191 LIT#LIT&1                                                         00014800
      IF(LIT.GT.MXIT) GO TO 200                                         00014900
      IF(EE.EQ.0.) GO TO 470                                            00015000
      PC#ABS((E0-EE)/EE)                                                00015100
      E0#EE                                                             00015200
      IF(PC.LT.EPS) GO TO 100                                           00015300
      CALL STEP(A,D,P,P0,P1,NP1,TOL)                                    00015400
      LLL#LLLL                                                          00015500
 121  DO 28 I#1,NP                                                      00015600
      PP0(I)#P(I)                                                       00015700
 28   P(I)#P(I)&D(I)                                                    00015800
      GO TO 29                                                          00015900
 200  WRITE (6,201)                                                     00016000
 201  FORMAT(30H0THE PROCESS IS NOT CONVERGING)                         00016100
      GO TO 470                                                         00016200
 100  LLL#LLL-1                                                         00016300
      IF(LLL.NE.0) GO TO 121                                            00016400
 470  DO 778 I#1,NP                                                     00016500
 778  FP(I)#SQRT(ABS(A(I,I)*EE))                                        00016600
      WRITE (6,779) (FP(I),I#1,NP)                                      00016700
 779  FORMAT(50H0ASSYMPTOTIC STANDARD DEVIATIONS OF THE PARAMETERS//    00016800
     X(10X,1P10E12.4))                                                  00016900
      DO 842 I#1,NP                                                     00017000
      FP(I)#SQRT(ABS(A(I,I)))                                           00017100
      DO 842 J#1,I                                                      00017200
      A(I,J)#A(I,J)/(FP(I)*FP(J))                                       00017300
 842  A(J,I)#A(I,J)                                                     00017400
10000 FORMAT (10F12.4)                                                  00017500
      WRITE (6,774)                                                     00017600
 774  FORMAT(48H0ASSYMTOTIC CORRELATION MATRIX OF THE PARAMETERS)       00017700
      L1#0                                                              00017800
 371  L0#L1&1                                                           00017900
      L1#MIN0(NP,L1&10)                                                 00018000
      WRITE (6,372) (L,L#L0,L1)                                         00018100
 372  FORMAT(1H0,10I12)                                                 00018200
      DO 373 I#1,NP                                                     00018300
 373  WRITE (6,374) I,(A(I,J),J#L0,L1)                                  00018400
 374  FORMAT(I4,2X,10F12.5)                                             00018500
      IF(L1.NE.NP) GO TO 371                                            00018600
 1515 WRITE (6,553)                                                     00018700
 553  FORMAT(46H1CASE       F            Y-F         VARIABLES)         00018800
      DO 551 L#1,NC                                                     00018900
      TT#X(ND,L)-F(L)                                                   00019000
 551  WRITE (6,552) L,F(L),TT,(X(I,L),I#1,NV)                           00019100
 552  FORMAT(1X,I4,10F12.5/(29X,8F12.5))                                00019200
      RETURN                                                            00019300
 192  WRITE (6,23) (P0(I),I#1,NP)                                       00019400
 23   FORMAT(7H1MINIMA15X,1P9E12.4/(22X,1P9E12.4))                      00019500
      WRITE (6,22) (P1(I),I#1,NP)                                       00019600
 22   FORMAT(7H0MAXIMA15X,1P9E12.4/(22X,1P9E12.4))                      00019700
      WRITE (6,195)                                                     00019800
 195  FORMAT(34H0ITERATION    ERROR     PARAMETERS/14X,4HMEAN/14X,6HSQUA00019900
     XRE)                                                               00020000
      GO TO 194                                                         00020100
 191  WRITE (6,24) (P0(I),I#1,NP)                                       00020200
 24   FORMAT(10H1MINIMUM    1PE12.4)                                    00020300
      WRITE (6,25) (P1(I),I#1,NP)                                       00020400
 25   FORMAT(10H0MAXIMUM     1PE12.4)                                   00020500
      WRITE (6,196)                                                     00020600
 196  FORMAT(34H0ITERATION  PARAMETER    ERROR                          00020700
     X/25X,4HMEAN/25X,6HSQUARE)                                         00020800
      GO TO 194                                                         00020900
      END                                                               00021000
$ID   0901HS 15 150    $BMDX85 NON-LINEAR LEAST SQUARES                 00021100
C        NON-LINEAR LEAST SQUARES - MAIN PROGRAM     APRIL  4, 1966     00021200
      DIMENSION DATE(3)                                                 00021300
      DATA (DATE(I),I=1,3)/6HAPRIL ,6H4, 196,1H6/                       00021400
      LOGICAL BL                                                        00021500
C     BL(Z)#Z.EQ.0.0 .AND. SIGN(1.,Z).EQ.(-1.)                          00021600
      DATA YES,ONO,GUESS,PROBLM,FINISH,AMON,AMOX/3HYES,2HNO,5HPARAM,6HPR00021700
     XOBLM,6HFINISH,6HMINMUM,6HMAXMUM/                                  00021800
      DIMENSION A(15000),P(100),P0(100),P1(100),F(108)                  00021900
      LLK#0                                                             00022000
 15   READ (5,1) PP,PC,NV,ND,NC,NP,TOL,EPS,MXIT,NF,IT,RE                00022100
      LLK#LLK&1                                                         00022200
    1 FORMAT(2A6,2I4,I6,I4,2F6.0,3I4,A3)                                00022300
C     IF(BL(TOL)) TOL#.00001                                            00022400
      IF (TOL-0)31,30,31                                                00022500
  30  TOL = 0.00001                                                     00022600
C     IF(BL(EPS)) EPS#.00001                                            00022700
  31  IF (EPS-0)33,32,33                                                00022800
  32  EPS = 0.00001                                                     00022900
C     IF(BL(MXIT)) MXIT#100                                             00023000
  33  IF (MXIT-0)35,34,35                                               00023100
  34  MXIT = 100                                                        00023200
  35  TOL = ABS(TOL)                                                    00023300
      IF(RE.NE.YES) RE#ONO                                              00023400
      IF(IT.EQ.0) IT#5                                                  00023500
      IF(RE.EQ.YES) REWIND IT                                           00023600
      NF#MAX0(1,NF)                                                     00023700
      NF#MIN0(NF,9)                                                     00023800
      WRITE (6,1000) (DATE(I),I=1,3),PC,NV,ND,NC,NP,TOL                 00023900
      WRITE (6,1001) EPS,MXIT,NF,IT,RE                                  00024000
      NF#12*NF                                                          00024100
      READ (5,2) (F(I),I#1,NF)                                          00024200
 2    FORMAT(12A6)                                                      00024300
      WRITE (6,1002) (F(I),I#1,NF)                                      00024400
 1000 FORMAT( 48H1BMDX85 - NON LINEAR LEAST SQUARES - VERSION OF 3A6/   00024500
     X/60H0HEALTH SCIENCES COMPUTING FACILITY, UCLA                     00024600
     X/32H0PROBLM CODE                     A6                           00024700
     X/32H0NUMBER OF VARIABLES              I6                          00024800
     X/32H0INDEX OF THE DEPENDENT VARIABLE I6                           00024900
     X/32H0NUMBER OF CASES                 I6                           00025000
     X/32H0NUMBER OF PARAMETERS            I6                           00025100
     X/32H0TOLERANCE                       F10.6)                       00025200
 1001 FORMAT(32H0EPSILON                         F10.6                  00025300
     X/32H0MAXIMUM NUMBER OF ITERATIONS    I6                           00025400
     X/32H0NUMBER OF VARIABLE FORMAT CARDS  I6                          00025500
     X/32H0ALTERNATE INPUT TAPE NUMBER     I6                           00025600
     X/32H0REWIND OPTION                   A6)                          00025700
 1002 FORMAT(16H0VARIABLE FORMAT 16X,16A6/(32X,16A6))                   00025800
      J#1                                                               00025900
      DO 3 L#1,NC                                                       00026000
      READ (IT,F)   (P(I),I=1,NV)                                       00026100
      WRITE (6,10001) L,(P(I),I=1,NV)                                   00026200
C     CALL TRANS(P,L,NV,SELECT)                                         00026300
      DO 3 I#1,NV                                                       00026400
      A(J)#P(I)                                                         00026500
      J#J&1                                                             00026600
   3  CONTINUE                                                          00026700
10001 FORMAT (I5,2X,2F12.5)                                             00026800
      NP1#NP&1                                                          00026900
      L1#1&NV*NC                                                        00027000
      L2#L1&NP1*NP1                                                     00027100
      L3#L2&NC                                                          00027200
      L4#L3&NP1*NP1                                                     00027300
      IF(L4.GT.15000) GO TO 600                                         00027400
      LLJ#0                                                             00027500
      DO 7 I#1,NP                                                       00027600
      P1(I)#1.E20                                                       00027700
 7    P0(I)#-1.E20                                                      00027800
 81   READ (5,2) PP                                                     00027900
      IF(PP.EQ.AMON) READ (5,12) (P0(I),I#1,NP)                         00028000
      IF(PP.EQ.AMOX) READ (5,12)(P1(I),I#1,NP)                          00028100
      IF(PP.EQ.PROBLM) GO TO 15                                         00028200
      IF(PP.EQ.FINISH) STOP                                             00028300
      IF(PP.EQ.GUESS) GO TO 18                                          00028400
      IF(PP.EQ.AMON .OR. PP.EQ.AMOX) GO TO 81                           00028500
      READ (5,22) (P(I),I#1,14)                                         00028600
      WRITE (6,23) (P(I),I#1,14)                                        00028700
 22   FORMAT(13A6,A2)                                                   00028800
 23   FORMAT(19H NON CONTROL CARD (13A6,A2,1H))                         00028900
      GO TO 81                                                          00029000
 18   READ (5,12) (P(I),I#1,NP)                                         00029100
12    FORMAT(6X, 9F8.4)                                                 00029200
      CALL MINIZ(A,A(L1),P,NV,NC,NP1,TOL,EPS,EE,ND,MXIT,LLK,P0,P1,A(L2) 00029300
     X,A(L3))                                                           00029400
      GO TO 81                                                          00029500
 600  WRITE (6,601)                                                     00029600
 601  FORMAT(45H0CONTROL CARDS INCORRECTLY ORDERED OR PUNCHED)          00029700
      STOP                                                              00029800
      END                                                               00029900