      subroutine tsunami_setprob()
      implicit none

      DOUBLE PRECISION pi, pi2
      COMMON /compi/ pi, pi2

      double precision a,b,h0
      common /common_initheight/ a,b,h0

      DOUBLE PRECISION  grav, dry_tolerance, sea_level
      COMMON /common_swe/ grav, dry_tolerance, sea_level

      double precision breaking, alpha
      common /common_sgn/ breaking, alpha

c     # These should be read in as options.

      open(10,file='setprob.data')
      read(10,*) grav
      read(10,*) a
      read(10,*) b
      read(10,*) h0
      read(10,*) breaking
      read(10,*) alpha
      read(10,*) dry_tolerance
      read(10,*) sea_level
      close(10)

      return
      end


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief solve of : D*[D+L]^(-1) x [b] = [b^]
!>    @param[in] N_I lengths of I-dimension of local matrix [M]
!>    @param[in] N_J lengths of J-dimension of local matrix [M]
!>    @param[in] N_K lengths of K-dimension of local matrix [M]
!>    @param[in] b vector [b]
!>    @param[in] MA diagonals of matrix [M]
!>    @param[in] MB diagonals of matrix [M]
!>    @param[in] MC diagonals of matrix [M]
!>    @param[in] MD diagonals of matrix [M]
!>    @param[out] b_hat the solution vector [b^]
!>    @details
!>    solve of : D*[D+L]^(-1) x [b] = [b^]\n
!>               with [M]=[L]+[D]+[R]\n
      SUBROUTINE ddl(n_i,n_j,n_k,b,b_hat,ma,mb,mc,md)
        use mod_OMP_TOOLS
        IMPLICIT NONE
        INCLUDE 'OMP_TOOLS.inc'
        INTEGER n_i, n_j, n_k, i, j, k
        DOUBLE PRECISION b(n_i,n_j,n_k), b_hat(n_i,n_j,n_k)
        DOUBLE PRECISION ma(n_i,n_j,n_k), mb(n_i,n_j,n_k)
        DOUBLE PRECISION mc(n_i,n_j,n_k), md(n_i,n_j,n_k)

!     ###################### not parallel Code !!! #########################
!     prepare [b^]
!     [b^] = D*(D+L)^(-1) * [b]
!$OMP master
        DO k = 1, n_k
          DO j = 1, n_j
            DO i = 1, n_i
              b_hat(i,j,k) = b(i,j,k)
              IF (i>1) b_hat(i,j,k) = b_hat(i,j,k) - &
                mc(i,j,k)*b_hat(i-1,j,k)
              IF (j>1) b_hat(i,j,k) = b_hat(i,j,k) - &
                mb(i,j,k)*b_hat(i,j-1,k)
              IF (k>1) b_hat(i,j,k) = b_hat(i,j,k) - &
                ma(i,j,k)*b_hat(i,j,k-1)
!AW           ugly hack ...
              IF (md(i,j,k)/=0.0D0) THEN
                b_hat(i,j,k) = b_hat(i,j,k)/md(i,j,k)
              END IF
            END DO
          END DO
        END DO
        DO k = 1, n_k
          DO j = 1, n_j
            DO i = 1, n_i
              b_hat(i,j,k) = b_hat(i,j,k)*md(i,j,k)
            END DO
          END DO
        END DO
!$OMP end master
!     ################### above not parallel Code !!! ######################
        RETURN
      END

!>    @brief solve of : [D+U]^(-1) x [x^] = [x]
!>    @param[in] N_I lengths of I-dimension of local matrix [M]
!>    @param[in] N_J lengths of J-dimension of local matrix [M]
!>    @param[in] N_K lengths of K-dimension of local matrix [M]
!>    @param[in] x_hat vector [x^]
!>    @param[in] MD diagonals of matrix [M]
!>    @param[in] ME diagonals of matrix [M]
!>    @param[in] MF diagonals of matrix [M]
!>    @param[in] MG diagonals of matrix [M]
!>    @param[out] x the solution vector [x]
      SUBROUTINE du(n_i,n_j,n_k,x_hat,x,md,me,mf,mg)
        IMPLICIT NONE
        INTEGER n_i, n_j, n_k, i, j, k
        DOUBLE PRECISION x(n_i,n_j,n_k), x_hat(n_i,n_j,n_k)
        DOUBLE PRECISION md(n_i,n_j,n_k), me(n_i,n_j,n_k)
        DOUBLE PRECISION mf(n_i,n_j,n_k), mg(n_i,n_j,n_k)

!     ###################### not parallel Code !!! #########################
!     compute [x]
!     [x] = (D+U)^(-1) * [x^]
        DO k = n_k, 1, -1
          DO j = n_j, 1, -1
            DO i = n_i, 1, -1
              x(i,j,k) = x_hat(i,j,k)
              IF (i<n_i) x(i,j,k) = x(i,j,k) - me(i,j,k)*x(i+1,j,k)
              IF (j<n_j) x(i,j,k) = x(i,j,k) - mf(i,j,k)*x(i,j+1,k)
              IF (k<n_k) x(i,j,k) = x(i,j,k) - mg(i,j,k)*x(i,j,k+1)
!AW           ugly hack ...
              IF (md(i,j,k)/=0.0D0) THEN
                x(i,j,k) = x(i,j,k)/md(i,j,k)
              END IF
            END DO
          END DO
        END DO
!     ################### above not parallel Code !!! ######################
        RETURN
      END


program nemo2d

use globals_mod
use setup_mod

use mesh_mod, only: mesh_t
use mesh_mod, only: mesh_init
use mesh_mod, only: mesh_dump

use kernel_mod, only: kernel_init

use timedisc_mod, only: evolve
use timestep_mod, only: calc_timestep

use setup_mod, only: setup_init

# ifdef _OPENMP
USE OMP_LIB, only: omp_get_thread_num
USE OMP_LIB, only: omp_get_num_threads
# endif

real(dp) :: simtime, timestep, nextdump, hydrotimestep

integer :: nsteps,ndumps
logical :: dodump, doloop

type(mesh_t) :: mesh

character(len=*), parameter  :: iohdr = "(5x,a4,5x,a5,5x,a10,8x,a10)"
character(len=*), parameter  :: iofmt = "(2(I9),2(ES18.5))"

real(dp), parameter :: CFL_eff = 0.5**(N_DIMS-1) / REAL(2*N_NODES-1,dp) * CFL

write (*,*) '                                                 .                 '
write (*,*) '                            ____     _          ":"                '
write (*,*) '  _ __   ___ _ __ ___   ___|___ \ __| |       ___:____     |"\/"|  '
write (*,*) " | '_ \ / _ \ '_ ` _ \ / _ \ __) / _` |     ,'        `.    \  /   "
write (*,*) " | | | |  __/ | | | | | (_) / __/ (_| |     |  O        \___/  |   "
write (*,*) " |_| |_|\___|_| |_| |_|\___/_____\__,_|   ~^~^~^~^~^~^~^~^~^~^~^~^~"
write (*,*) "                                            ~^~^ ~^~ ^~^~^ ~^~^    "

write (*,*)

# ifdef _OPENMP
!$OMP Parallel
if (omp_get_thread_num() == 0) then
    write (*,*) ' ## OPENMP IS ACTIVE: number of threads',omp_get_num_threads()
end if
!$OMP end Parallel
write (*,*)
# endif

call kernel_init()
call mesh_init(mesh)
call setup_init(mesh)

simtime  = inittime
timestep = 0.0

nsteps = 0
ndumps = 0

call mesh_dump(mesh,ndumps)
write (*,iohdr) '#io','#steps','simtime','timestep'
write (*,*)
write (*,iofmt) ndumps,nsteps, simtime, hydrotimestep
nextdump = simtime + dtdump
ndumps = ndumps + 1
dodump = .false.

doloop = .true.
do while (doloop)

    hydrotimestep = calc_timestep(mesh)
    timestep = CFL_eff*hydrotimestep

    if (simtime + timestep > stoptime) then
        timestep = abs(stoptime - simtime)
        doloop = .false.
        dodump = .true.

    else if (simtime + timestep > nextdump) then
        timestep = abs(nextdump - simtime)
        dodump = .true.
    end if

    call evolve(mesh,simtime,timestep)

    nsteps  = nsteps  + 1
    simtime = simtime + timestep

    if (dodump) then
        call mesh_dump(mesh,ndumps)
        write (*,iofmt) ndumps,nsteps, simtime, hydrotimestep
        nextdump = simtime + dtdump
        ndumps = ndumps + 1
        dodump = .false.
    end if

end do

end program


! test print, write statements
!
!  formats:
!     A : une string
!     / : \n
!     5i4 : 5 entiers de taille 4 caracteres
!     5f10.5: 5 floats de taille 10 caracteres avec 5 decimales

program test_formats

    !real*8 nd_scn(5)  ! (-Wpedantic) Warning: GNU Extension: Nonstandard type declaration REAL*8 at (1)
    !real(8) nd_scn(5) ! OK
    real(kind=8) :: nd_scn(5) ! encore plus "moderne"

    integer :: sz = 2
    character(len=20) :: fmt

    nd_scn(1) = 1.0
    nd_scn(2) = 222222.222222222
    nd_scn(3) = 10000.0   ! < genere des etoiles
    nd_scn(4) = 4.444444444444444
    nd_scn(5) = 5.555555555555555

    print "(A)", 'nd_scn ='
    write (*, 10) (nd_scn(ni), ni=1, 5)

10  format(1x, f26.16)  !< equivalent portable
!10 format(1x,f) !< accepté par uniquement par intel
!                (gfortran: Error: Nonnegative width required in format string)

    print "(/,A)", 'en 1 ligne...'  ! / pour sauter une ligne (/ == \n)

    print "(1x, f26.16)", (nd_scn(ni), ni=1, 5)

    print "(/,A)", 'sur 1 ligne...'  ! / pour sauter une ligne (/ == \n)
    print "(1x, 5f26.16)", (nd_scn(ni), ni=1, 5)

    print "(/,A,I2,A)", 'format variable (sur sz=', sz, ' colonnes)...'  ! "Variable FORMAT expressions"
    write (fmt, *) sz
    print "(1x, "//adjustl(fmt)//"f26.16)", (nd_scn(ni), ni=1, 5)

    !print '(/,1X,A,T72,A,$)', 'Nombre de type d''elements', ' volumiques utilises dans ce maillage', ': '

    !print '(/,1X,A,I1,T72,A,$)', 'Donnez le code (4 car.) de', ' l''element type ', sz, ': '

end program test_formats


        subroutine HFB_20(U,V,ham,delta10,H20,NDIM)
!      ....................................................
!
!      20    +       *    +   t   *    +       *   +   *    *
!     H   = U * h * V  - V * h * U  + U * d * U - V * d  * V
!
!      ....................................................

        USE VAPHFB_PAR
        implicit real*8 (a-h,o-z)

        DIMENSION U(NDIM,NDIM)
        DIMENSION V(NDIM,NDIM)
        DIMENSION ham(NDIM,NDIM)
        DIMENSION H20(NDIM,NDIM)
        DIMENSION H20AUX(NDIM,NDIM)
        DIMENSION delta10(NDIM,NDIM)
        DIMENSION AUX1(NDIM,NDIM)
        DIMENSION AUX2(NDIM,NDIM)
        DIMENSION AUX3(NDIM,NDIM)
        DIMENSION AUX4(NDIM,NDIM)
        DIMENSION AUX5(NDIM,NDIM)
        DIMENSION AUX6(NDIM,NDIM)
        DIMENSION AUX7(NDIM,NDIM)
        DIMENSION AUX8(NDIM,NDIM)

        call DGEMM ('t','n',NDIM,NDIM,NDIM,one,     &
     &	U,NDIM,ham,NDIM,zero,AUX1,NDIM)
            call DGEMM ('n','n',NDIM,NDIM,NDIM,one, &
     &	AUX1,NDIM,V,NDIM,zero,AUX2,NDIM)

            call DGEMM ('t','t',NDIM,NDIM,NDIM,one, &
     &	V,NDIM,ham,NDIM,zero,AUX3,NDIM)
            call DGEMM ('n','n',NDIM,NDIM,NDIM,one, &
     &	AUX3,NDIM,U,NDIM,zero,AUX4,NDIM)

            call DGEMM ('t','n',NDIM,NDIM,NDIM,one, &
     &	U,NDIM,delta10,NDIM,zero,AUX5,NDIM)
            call DGEMM ('n','n',NDIM,NDIM,NDIM,one, &
     &	AUX5,NDIM,U,NDIM,zero,AUX6,NDIM)

            call DGEMM ('t','n',NDIM,NDIM,NDIM,one, &
     &	V,NDIM,delta10,NDIM,zero,AUX7,NDIM)
            call DGEMM ('n','n',NDIM,NDIM,NDIM,one, &
     &	AUX7,NDIM,V,NDIM,zero,AUX8,NDIM)

        do ii=1,NDIM
          do jj=1,NDIM
            H20AUX(jj,ii)= AUX2(jj,ii)-AUX4(jj,ii)+  &
     &	    AUX6(jj,ii)-AUX8(jj,ii)
          end do
        end do
        do ii=1,NDIM
          do jj=1,NDIM
            H20(jj,ii)= 0.5*(H20AUX(jj,ii)  -H20AUX(ii,jj))
          end do
        end do

        return
        END SUBROUTINE

        subroutine HFB_GRAD_PHI(ZU,ZV,Zham,Zdelta10,zdelta01,ZH20,NDIM)
        USE VAPHFB_PAR
        implicit real*8 (a-h,o-y)
        implicit complex*16 (z)
        DIMENSION ZU(NDIM,NDIM)
	DIMENSION ZV(NDIM,NDIM)
	DIMENSION Zham(NDIM,NDIM)
	DIMENSION ZH20(NDIM,NDIM)
	DIMENSION Zdelta10(NDIM,NDIM)
	DIMENSION Zdelta01(NDIM,NDIM)
	DIMENSION ZAUX1(NDIM,NDIM)
	DIMENSION ZAUX2(NDIM,NDIM)
	DIMENSION ZAUX3(NDIM,NDIM)
	DIMENSION ZAUX4(NDIM,NDIM)
	DIMENSION ZAUX5(NDIM,NDIM)
	DIMENSION ZAUX6(NDIM,NDIM)
	DIMENSION ZAUX7(NDIM,NDIM)
	DIMENSION ZAUX8(NDIM,NDIM)

	!Ut h V
	call ZGEMM ('t','n',NDIM,NDIM,NDIM,zone,  &
     &	ZU,NDIM,Zham,NDIM,zzero,ZAUX1,NDIM)
     	call ZGEMM ('n','n',NDIM,NDIM,NDIM,zone,  &
     &	ZAUX1,NDIM,ZV,NDIM,zzero,ZAUX2,NDIM)

	!Vt ht U
     	call ZGEMM ('t','t',NDIM,NDIM,NDIM,zone,  &
     &	ZV,NDIM,Zham,NDIM,zzero,ZAUX3,NDIM)
     	call ZGEMM ('n','n',NDIM,NDIM,NDIM,zone,  &
     &	ZAUX3,NDIM,ZU,NDIM,zzero,ZAUX4,NDIM)

	!Ut Delta10 U
     	call ZGEMM ('t','n',NDIM,NDIM,NDIM,zone,  &
     &	ZU,NDIM,Zdelta10,NDIM,zzero,ZAUX5,NDIM)
     	call ZGEMM ('n','n',NDIM,NDIM,NDIM,zone,  &
     &	ZAUX5,NDIM,ZU,NDIM,zzero,ZAUX6,NDIM)

	!Vt Delta01 V
     	call ZGEMM ('t','n',NDIM,NDIM,NDIM,zone, &
     &	ZV,NDIM,Zdelta01,NDIM,zzero,ZAUX7,NDIM)
     	call ZGEMM ('n','n',NDIM,NDIM,NDIM,zone, &
     &	ZAUX7,NDIM,ZV,NDIM,zzero,ZAUX8,NDIM)

	do ii=1,NDIM
	  do jj=1,NDIM
	    ZH20(jj,ii)= ZAUX2(jj,ii)-ZAUX4(jj,ii)+  &
     &	    ZAUX6(jj,ii)-ZAUX8(jj,ii)
	  end do
	end do

	return
	END SUBROUTINE

!     ......................................................
      SUBROUTINE F2_0(RO,AKAPA10,AKAPA01,AFME,AF2ME,AF2_MV,NDIM)
!     ......................................................
        USE VAPHFB_PAR
        implicit real*8 (a-h,o-z)
	DIMENSION RO(NDIM,NDIM)
	DIMENSION AKAPA10(NDIM,NDIM)
	DIMENSION AKAPA01(NDIM,NDIM)
	DIMENSION AFME(NDIM,NDIM)
	DIMENSION AF2ME(NDIM,NDIM)

	DIMENSION AUX1(NDIM,NDIM)
	DIMENSION AUX2(NDIM,NDIM)
	DIMENSION AUX3(NDIM,NDIM)
	DIMENSION AUX4(NDIM,NDIM)
	DIMENSION AUX5(NDIM,NDIM)
	DIMENSION AUX6(NDIM,NDIM)

	call DGEMM ('n','n',NDIM,NDIM,NDIM,one,   &
     &	AF2ME,NDIM,ro,NDIM,zero,AUX1,NDIM)

	call DGEMM ('n','n',NDIM,NDIM,NDIM,one,   &
     &	AFME,NDIM,ro,NDIM,zero,AUX2,NDIM)

	call DGEMM ('n','n',NDIM,NDIM,NDIM,one,   &
     &	AFME,NDIM,AKAPA10,NDIM,zero,AUX3,NDIM)

	call DGEMM ('t','t',NDIM,NDIM,NDIM,one,   &
     &	AFME,NDIM,AKAPA01,NDIM,zero,AUX4,NDIM)

	call DGEMM ('n','n',NDIM,NDIM,NDIM,one,   &
     &	AUX2,NDIM,AUX2,NDIM,zero,AUX5,NDIM)

	call DGEMM ('n','n',NDIM,NDIM,NDIM,one,   &
     &	AUX3,NDIM,AUX4,NDIM,zero,AUX6,NDIM)

	tr1=zero
	tr2=zero
	tr3=zero
	tr4=zero
	do ii=1,NDIM
         tr1=tr1+AUX1(ii,ii)
         tr2=tr2+AUX2(ii,ii)
         tr3=tr3+AUX5(ii,ii)
         tr4=tr4+AUX6(ii,ii)
	end do

	AF2_MV=tr1+tr2*tr2-tr3+tr4

!       print *, 'tr1=',tr1
!       print *, 'tr2*tr2=',tr2*tr2
!       print *, '-tr3=',-tr3
!       print *, 'tr4=',tr4

        end subroutine


      SUBROUTINE ACCEL(ISCRPT,NPLAN,NREL,NMASS,NPINMS,T)
      IMPLICIT REAL*8 (A,B,C,D,E,F,G,H,O,P,Q,R,S,T,U,V,W,X,Y,Z)
      DOUBLE PRECISION MASS,KSQ,KSDM15,LMA
      DIMENSION MASS(13),X(13),Y(13),Z(13),XDD(13),YDD(13),ZDD(13)
     .,UX(13),UY(13),UZ(13)
      REAL*8 MX,MY,MZ
      COMMON XP(13,59),YP(13,59),ZP(13,59),XDDP(13,59),YDDP(13,59)
     .,ZDDP(13,59),XD(13),YD(13),ZD(13),KSQ
      DATA MASS/3.040432924D-6,1.660136795D-7,2.447839598D-6
     .         ,3.227149362D-7,9.547861040D-4,2.858367872D-4
     .         ,4.372731645D-5,5.177591384D-5,3.333333333D-7
     .         ,5.9       D-10,1.3       D-10,1.2       D-10,0.D0/
      DATA FOURM/3.948251502D-8/,CM2/3.335661215D-5/
      DATA EMRAT/81.3007D0/,F1/.9878494351D0/,F2/.0121505649/
      DATA CLTY,CLTZ/-.3978811766D0,.9174369566D0/
      DATA EMRATP1/82.3007D0/,T1950/2433282.423D0/

      DO I=1,NPLAN
          X(I)=XP(I,ISCRPT)
          Y(I)=YP(I,ISCRPT)
          Z(I)=ZP(I,ISCRPT)
      enddo
C
C CALCULATE MUTUAL ACCELERATIONS BETWEEN SUN AND EACH PLANET
      DO I=1,NPLAN
          RLCM1=1.D0/SQRT(X(I)*X(I)+Y(I)*Y(I)+Z(I)*Z(I))
          RLCM3=RLCM1*RLCM1*RLCM1

          IF(I.eq.1)then

!             CALCULATE NEWTONIAN SOLAR ACCELERATION OF EARTH MOON SYSTEM

!             Get Earth Moon vector for equinox of date
              CALL MOON_BRWN(T,MX,MY,MZ)

!             Convert vector to 1950 coordinates
              CALL PRECES(T,T1950,MX,MY,MZ,1)

              PX = -MX/EMRATP1
              PY = -MY/EMRATP1
              PZ = -MZ/EMRATP1

              XE=X(1)+PX
              YE=Y(1)+PY
              ZE=Z(1)+PZ

              XM=X(1)-PX*EMRAT
              YM=Y(1)-PY*EMRAT
              ZM=Z(1)-PZ*EMRAT

              ARGE=-KSQ/SQRT(XE*XE+YE*YE+ZE*ZE)**3
              ARGM=-KSQ/SQRT(XM*XM+YM*YM+ZM*ZM)**3

              XDD(I)=ARGE*XE*F1+ARGM*XM*F2
              YDD(I)=ARGE*YE*F1+ARGM*YM*F2
              ZDD(I)=ARGE*ZE*F1+ARGM*ZM*F2

          else
              ARG=-KSQ*RLCM3
              XDD(I)=ARG*X(I)
              YDD(I)=ARG*Y(I)
              ZDD(I)=ARG*Z(I)

          endif ! I .eq. 1

30        IF(NREL.GE.I)THEN

!             ADD PERTURBATIVE ACCELERATION DUE TO GENERAL RELATIVITY
              RDRD=X(I)*XD(I)+Y(I)*YD(I)+Z(I)*ZD(I)
              VSQ=XD(I)*XD(I)+YD(I)*YD(I)+ZD(I)*ZD(I)
              A=FOURM*RLCM1-VSQ*CM2
              B=FOURM*RDRD*RLCM3
              XDD(I)=XDD(I)*(1.D0-A)+B*XD(I)
              YDD(I)=YDD(I)*(1.D0-A)+B*YD(I)
              ZDD(I)=ZDD(I)*(1.D0-A)+B*ZD(I)

          endif

          UX(I)=XDD(I)*MASS(I)
          UY(I)=YDD(I)*MASS(I)
          UZ(I)=ZDD(I)*MASS(I)

      enddo ! N = 1,nplan

C
C ADD IN MUTUAL ACCELERATIONS BETWEEN PAIRS OF PLANETS
      DO I=1,NPINMS
          I1=I+1
          DO J=I1,NPLAN
              XDELT=X(J)-X(I)
              YDELT=Y(J)-Y(I)
              ZDELT=Z(J)-Z(I)
              KSDM15=KSQ/SQRT(XDELT*XDELT+YDELT*YDELT+ZDELT*ZDELT)**3
              ARG=KSDM15*MASS(J)
              XDD(I)=XDD(I)+ARG*XDELT
              YDD(I)=YDD(I)+ARG*YDELT
              ZDD(I)=ZDD(I)+ARG*ZDELT
              ARG=-KSDM15*MASS(I)
              XDD(J)=XDD(J)+ARG*XDELT
              YDD(J)=YDD(J)+ARG*YDELT
              ZDD(J)=ZDD(J)+ARG*ZDELT

          enddo

      enddo
C
C CALCULATE TOTAL ACCELERATION OF SUN
      SUMUX=UX(1)
      SUMUY=UY(1)
      SUMUZ=UZ(1)

      DO I=2,NMASS
          SUMUX=SUMUX+UX(I)
          SUMUY=SUMUY+UY(I)
          SUMUZ=SUMUZ+UZ(I)

      enddo
C
C COMPUTE ACC. RELATIVE TO SUN = TOTAL ACC. - ACC. OF SUN
      DO I=1,NPLAN
          XDD(I)=XDD(I)+SUMUX
          YDD(I)=YDD(I)+SUMUY
          ZDD(I)=ZDD(I)+SUMUZ
      enddo

C
C PLACE ACCELERATIONS IN TWO DIMENSIONAL ARRAY
      DO I=1,NPLAN
          XDDP(I,ISCRPT)=XDD(I)
          YDDP(I,ISCRPT)=YDD(I)
          ZDDP(I,ISCRPT)=ZDD(I)
      enddo

      RETURN
      END


*DECK DCGS
      SUBROUTINE DCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC,
     $     MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
     $     R, R0, P, Q, U, V1, V2, RWORK, IWORK)
C***BEGIN PROLOGUE  DCGS
C***DATE WRITTEN   890404   (YYMMDD)
C***REVISION DATE  890404   (YYMMDD)
C***CATEGORY NO.  D2A4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(DCGS-D),
C             Non-Symmetric Linear system, Sparse,
C             Iterative Precondition,  BiConjugate Gradient
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Preconditioned BiConjugate Gradient Sparse Ax=b solver.
C            Routine to solve a Non-Symmetric linear system Ax = b
C            using the Preconditioned BiConjugate Gradient method.
C***DESCRIPTION
C *Usage:
C      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C      INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINABLE)
C      DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N)
C      DOUBLE PRECISION Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINABLE)
C      EXTERNAL MATVEC, MSOLVE
C
C      CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC,
C     $     MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
C     $     R, R0, P, Q, U, V1, V2, RWORK, IWORK)
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Double Precision A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "Description", below
C         for more late breaking details...
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MATVEC :EXT      External.
C         Name of a routine which  performs the matrix vector multiply
C         operation  Y = A*X  given A and X.  The  name of  the MATVEC
C         routine must  be declared external  in the  calling program.
C         The calling sequence of MATVEC is:
C             CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A*X upon
C         return,  X is an input  vector.  NELT, IA,  JA,  A and  ISYM
C         define the SLAP matrix data structure: see Description,below.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R  for Z
C         given R with the preconditioning matrix M (M is supplied via
C         RWORK  and IWORK arrays).   The name  of  the MSOLVE routine
C         must be declared  external  in the  calling   program.   The
C         calling sequence of MSLOVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, R is  the right-hand side
C         vector, and Z is the solution upon return.  NELT,  IA, JA, A
C         and  ISYM define the SLAP  matrix  data structure: see
C         Description, below.  RWORK is a  double precision array that
C         can be used
C         to  pass   necessary  preconditioning     information and/or
C         workspace to MSOLVE.  IWORK is an integer work array for the
C         same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         This routine must calculate the residual from R = A*X - B.
C         This is un-natural and hence expensive for this type of iter-
C         ative method.  ITOL=2 is *STRONGLY* recommended.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than tol, where M-inv time a vector is the pre-
C         conditioning step.  This is the *NATURAL* stopping for this
C         iterative method and is *STRONGLY* recommended.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than tol) through a common block,
C         COMMON /SOLBLK/ SOLN( )
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than tol.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*D1MACH(3).  Iteration proceeded.
C           IERR = 5 => Breakdown of the method detected.
C                       $(r0,r) approximately 0.0$.
C           IERR = 6 => Stagnation of the method detected.
C                        $(r0,v) approximately 0.0$.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :WORK     Double Precision R(N).
C R0     :WORK     Double Precision R0(N).
C P      :WORK     Double Precision P(N).
C Q      :WORK     Double Precision Q(N).
C U      :WORK     Double Precision U(N).
C V1     :WORK     Double Precision V1(N).
C V2     :WORK     Double Precision V2(N).
C RWORK  :WORK     Double Precision RWORK(USER DEFINED).
C         Double Precision array that can be used for workspace in
C         MSOLVE.
C IWORK  :WORK     Integer IWORK(USER DEFINED).
C         Integer array that can be used for workspace in MSOLVE.
C
C *Description
C       This routine does  not care  what matrix data   structure is
C       used for  A and M.  It simply   calls  the MATVEC and MSOLVE
C       routines, with  the arguments as  described above.  The user
C       could write any type of structure and the appropriate MATVEC
C       and MSOLVE routines.  It is assumed  that A is stored in the
C       IA, JA, A  arrays in some fashion and  that M (or INV(M)) is
C       stored  in  IWORK  and  RWORK   in  some fashion.   The SLAP
C       routines SDBCG and DSLUCS are examples of this procedure.
C
C       Two  examples  of  matrix  data structures  are the: 1) SLAP
C       Triad  format and 2) SLAP Column format.
C
C       =================== S L A P Triad format ===================
C
C       In  this   format only the  non-zeros are  stored.  They may
C       appear  in *ANY* order.   The user  supplies three arrays of
C       length NELT, where  NELT  is the number  of non-zeros in the
C       matrix:  (IA(NELT), JA(NELT),  A(NELT)).  For each  non-zero
C       the  user puts   the row  and  column index   of that matrix
C       element in the IA and JA arrays.  The  value of the non-zero
C       matrix  element is  placed in  the corresponding location of
C       the A  array.  This is  an extremely easy data  structure to
C       generate.  On  the other hand it  is  not too  efficient  on
C       vector  computers   for the  iterative  solution  of  linear
C       systems.  Hence, SLAP  changes this input  data structure to
C       the SLAP   Column  format for the  iteration (but   does not
C       change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C       This routine requires  that the  matrix  A be  stored in the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C       5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C       1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Double Precision
C *See Also:
C       DSDCGS, DSLUCS
C***REFERENCES  1. P. Sonneveld, ``CGS, a fast Lanczos-type solver
C                 for nonsymmetric linear systems'', Delft University
C                 of Technology Report 84-16, Department of Math-
C                 ematics and Informatics, Julianalaan 132, 2628 BL
C                 Delft, Phone 015-784568.
C
C               2. E.F. Kaasschieter, ``The solution of non-symmetric
C                 linear systems by bi-conjugate gradients or conjugate
C                 gradients squared,''  Delft University of Tech-
C                 nology Report 86-21, Department of Mathematics and
C                 Informatics, Julianalaan 132, 2628 BL Delft,
C                 Phone 015-784568.
C***ROUTINES CALLED  MATVEC, MSOLVE, ISDCGS, DDOT, D1MACH
C***END PROLOGUE  DCGS
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
      INTEGER ITER, IERR, IUNIT, IWORK(*)
      DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N)
      DOUBLE PRECISION Q(N), U(N), V1(N), V2(N), RWORK(*)
      EXTERNAL MATVEC, MSOLVE
C
C         Check some of the input data.
C***FIRST EXECUTABLE STATEMENT  DCGS
      ITER = 0
      IERR = 0
      IF( N.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      TOLMIN = 500.0*D1MACH(3)
      IF( TOL.LT.TOLMIN ) THEN
         TOL = TOLMIN
         IERR = 4
      ENDIF
C
C         Calculate initial residual and pseudo-residual, and check
C         stopping criterion.
      CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM)
      DO 10 I = 1, N
         V1(I)  = R(I) - B(I)
 10   CONTINUE
      CALL MSOLVE(N, V1, R, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C
      IF( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q,
     $     U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
     $     GO TO 200
      IF( IERR.NE.0 ) RETURN
C
C         Set initial values.
C
      FUZZ = D1MACH(3)**2
      DO 20 I = 1, N
         R0(I) = R(I)
 20   CONTINUE
      RHONM1 = 1.0
C
C         ***** ITERATION LOOP *****
C
      DO 100 K=1,ITMAX
         ITER = K
C
C         Calculate coefficient BK and direction vectors U, V and P.
         RHON = DDOT(N, R0, 1, R, 1)
         IF( ABS(RHONM1).LT.FUZZ ) GOTO 998
         BK = RHON/RHONM1
         IF( ITER.EQ.1 ) THEN
            DO 30 I = 1, N
               U(I) = R(I)
               P(I) = R(I)
 30         CONTINUE
         ELSE
            DO 40 I = 1, N
               U(I) = R(I) + BK*Q(I)
               V1(I) = Q(I) + BK*P(I)
 40         CONTINUE
            DO 50 I = 1, N
               P(I) = U(I) + BK*V1(I)
 50         CONTINUE
         ENDIF
C
C         Calculate coefficient AK, new iterate X, Q
         CALL MATVEC(N, P, V2, NELT, IA, JA, A, ISYM)
         CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK)
         SIGMA = DDOT(N, R0, 1, V1, 1)
         IF( ABS(SIGMA).LT.FUZZ ) GOTO 999
         AK = RHON/SIGMA
         AKM = -AK
         DO 60 I = 1, N
            Q(I) = U(I) + AKM*V1(I)
 60      CONTINUE
         DO 70 I = 1, N
            V1(I) = U(I) + Q(I)
 70      CONTINUE
C         X = X - ak*V1.
         CALL DAXPY( N, AKM, V1, 1, X, 1 )
C                     -1
C         R = R - ak*M  *A*V1
         CALL MATVEC(N, V1, V2, NELT, IA, JA, A, ISYM)
         CALL MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK)
         CALL DAXPY( N, AKM, V1, 1, R, 1 )
C
C         check stopping criterion.
         IF( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     $        ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q,
     $        U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
     $        GO TO 200
C
C         Update RHO.
         RHONM1 = RHON
 100  CONTINUE
C
C         *****   end of loop  *****
C         Stopping criterion not satisfied.
      ITER = ITMAX + 1
      IERR = 2
 200  RETURN
C
C         Breakdown of method detected.
 998  IERR = 5
      RETURN
C
C         Stagnation of method detected.
 999  IERR = 6
      RETURN
C------------- LAST LINE OF DCGS FOLLOWS ----------------------------
      END
*DECK DSDCGS
      SUBROUTINE DSDCGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C***BEGIN PROLOGUE  DSDCGS
C***DATE WRITTEN   890404   (YYMMDD)
C***REVISION DATE  890404   (YYMMDD)
C***CATEGORY NO.  D2A4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(SSDCGS-D),
C             Non-Symmetric Linear system, Sparse,
C             Iterative Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Diagonally Scaled CGS Sparse Ax=b Solver.
C            Routine to solve a linear system  Ax = b  using the
C            BiConjugate Gradient Squared method with diagonal scaling.
C***DESCRIPTION
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW
C     DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N)
C
C     CALL DSDCGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Double Precision A(NELT).
C         These arrays should hold the matrix A in either the SLAP
C         Triad format or the SLAP Column format.  See "Description",
C         below.  If the SLAP Triad format is chosen it is changed
C         internally to the SLAP Column format.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         This routine must calculate the residual from R = A*X - B.
C         This is un-natural and hence expensive for this type of iter-
C         ative method.  ITOL=2 is *STRONGLY* recommended.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than tol, where M-inv time a vector is the pre-
C         conditioning step.  This is the *NATURAL* stopping for this
C         iterative method and is *STRONGLY* recommended.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*D1MACH(3).  Iteration proceeded.
C           IERR = 5 => Breakdown of the method detected.
C                       $(r0,r) approximately 0.0$.
C           IERR = 6 => Stagnation of the method detected.
C                        $(r0,v) approximately 0.0$.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C RWORK  :WORK     Double Precision RWORK(LENW).
C         Double Precision array used for workspace.
C LENW   :IN       Integer.
C         Length of the double precision workspace, RWORK.  LENW >= 8*N.
C IWORK  :WORK     Integer IWORK(LENIW).
C         Used to hold pointers into the RWORK array.
C         Upon return the following locations of IWORK hold information
C         which may be of use to the user:
C         IWORK(9)  Amount of Integer workspace actually used.
C         IWORK(10) Amount of Double Precision workspace actually used.
C LENIW  :IN       Integer.
C         Length of the integer workspace, IWORK.  LENIW >= 10.
C
C *Description:
C       This  routine performs  preconditioned  BiConjugate gradient
C       method on the Non-Symmetric positive definite  linear system
C       Ax=b. The preconditioner is M = DIAG(A), the diagonal of the
C       matrix   A.   This is the  simplest   of preconditioners and
C       vectorizes very well.
C
C       The Sparse Linear Algebra Package (SLAP) utilizes two matrix
C       data structures: 1) the  SLAP Triad  format or  2)  the SLAP
C       Column format.  The user can hand this routine either of the
C       of these data structures and SLAP  will figure out  which on
C       is being used and act accordingly.
C
C       =================== S L A P Triad format ===================
C
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero   matrix  element is  placed  in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C       This routine requires  that the  matrix  A be  stored in the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C       5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C       1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Double Precision
C *Side Effects:
C       The SLAP Triad format (IA, JA, A) is  modified internally to
C       be   the SLAP  Column format.   See above.
C
C *See Also:
C       DCGS, DLUBCG
C***REFERENCES  1. P. Sonneveld, ``CGS, a fast Lanczos-type solver
C                 for nonsymmetric linear systems'', Delft University
C                 of Technology Report 84-16, Department of Math-
C                 ematics and Informatics, Julianalaan 132, 2628 BL
C                 Delft, Phone 015-784568.
C
C               2. E.F. Kaasschieter, ``The solution of non-symmetric
C                 linear systems by bi-conjugate gradients or conjugate
C                 gradients squared,''  Delft University of Tech-
C                 nology Report 86-21, Department of Mathematics and
C                 Informatics, Julianalaan 132, 2628 BL Delft,
C                 Phone 015-784568.
C***ROUTINES CALLED  DS2Y, DCHKW, DSDS, DCGS
C***END PROLOGUE  DSDCGS
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
      INTEGER IERR, LENW, IWORK(LENIW), LENIW
      DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, RWORK(LENW)
      EXTERNAL DSMV, DSDI
      PARAMETER (LOCRB=1, LOCIB=11)
C
C         Change the SLAP input matrix IA, JA, A to SLAP-Column format.
C***FIRST EXECUTABLE STATEMENT  DSDCGS
      IERR = 0
      IF( N.LT.1 .OR. NELT.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      CALL DS2Y( N, NELT, IA, JA, A, ISYM )
C
C         Set up the workspace.  Compute the inverse of the
C         diagonal of the matrix.
      LOCIW = LOCIB
C
      LOCDIN = LOCRB
      LOCR  = LOCDIN + N
      LOCR0 = LOCR + N
      LOCP  = LOCR0 + N
      LOCQ  = LOCP + N
      LOCU  = LOCQ + N
      LOCV1 = LOCU + N
      LOCV2 = LOCV1 + N
      LOCW  = LOCV2 + N
C
C         Check the workspace allocations.
      CALL DCHKW( 'DSDCGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR )
      IF( IERR.NE.0 ) RETURN
C
      IWORK(4) = LOCDIN
      IWORK(9) = LOCIW
      IWORK(10) = LOCW
C
      CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN))
C
C         Perform the Diagonally Scaled
C         BiConjugate Gradient Squared algorithm.
      CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, DSMV,
     $     DSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
     $     RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP),
     $     RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1),
     $     RWORK(LOCV2), RWORK(1), IWORK(1))
      RETURN
C------------- LAST LINE OF DSDCGS FOLLOWS ----------------------------
      END
*DECK DSLUCS
      SUBROUTINE DSLUCS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C***BEGIN PROLOGUE  DSLUCS
C***DATE WRITTEN   890404   (YYMMDD)
C***REVISION DATE  890404   (YYMMDD)
C***CATEGORY NO.  D2A4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(SSLUCS-D),
C             Non-Symmetric Linear system, Sparse,
C             Iterative incomplete LU Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Incomplete LU BiConjugate Gradient Sparse Ax=b solver.
C            Routine to solve a linear system  Ax = b  using the
C            BiConjugate Gradient  method  with  Incomplete   LU
C            decomposition preconditioning.
C***DESCRIPTION
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER ITER, IERR, IUNIT, LENW, IWORK(NEL+NU+4*N+2), LENIW
C     DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NEL+NU+8*N)
C
C     CALL DSLUCS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW)
C
C *Arguments:
C N      :IN       Integer.
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Double Precision A(NELT).
C         These arrays should hold the matrix A in either the SLAP
C         Triad format or the SLAP Column format.  See "Description",
C         below.  If the SLAP Triad format is chosen it is changed
C         internally to the SLAP Column format.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         This routine must calculate the residual from R = A*X - B.
C         This is un-natural and hence expensive for this type of iter-
C         ative method.  ITOL=2 is *STRONGLY* recommended.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than tol, where M-inv time a vector is the pre-
C         conditioning step.  This is the *NATURAL* stopping for this
C         iterative method and is *STRONGLY* recommended.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*D1MACH(3).  Iteration proceeded.
C           IERR = 5 => Breakdown of the method detected.
C                       $(r0,r) approximately 0.0$.
C           IERR = 6 => Stagnation of the method detected.
C                        $(r0,v) approximately 0.0$.
C           IERR = 7 => Incomplete factorization broke down
C                       and was fudged.  Resulting preconditioning may
C                       be less than the best.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C RWORK  :WORK     Double Precision RWORK(LENW).
C         Double Precision array used for workspace.  NEL is the
C         number of non-
C         zeros in the lower triangle of the matrix (including the
C         diagonal).  NU is the number of nonzeros in the upper
C         triangle of the matrix (including the diagonal).
C LENW   :IN       Integer.
C         Length of the double precision workspace, RWORK.
C         LENW >= NEL+NU+8*N.
C IWORK  :WORK     Integer IWORK(LENIW).
C         Integer array used for workspace.  NEL is the number of non-
C         zeros in the lower triangle of the matrix (including the
C         diagonal).  NU is the number of nonzeros in the upper
C         triangle of the matrix (including the diagonal).
C         Upon return the following locations of IWORK hold information
C         which may be of use to the user:
C         IWORK(9)  Amount of Integer workspace actually used.
C         IWORK(10) Amount of Double Precision workspace actually used.
C LENIW  :IN       Integer.
C         Length of the integer workspace, IWORK.
C         LENIW >= NEL+NU+4*N+12.
C
C *Description:
C       This routine is simply a  driver for the DCGSN  routine.  It
C       calls the DSILUS routine to set  up the  preconditioning and
C       then  calls DCGSN with  the appropriate   MATVEC, MTTVEC and
C       MSOLVE, MTSOLV routines.
C
C       The Sparse Linear Algebra Package (SLAP) utilizes two matrix
C       data structures: 1) the  SLAP Triad  format or  2)  the SLAP
C       Column format.  The user can hand this routine either of the
C       of these data structures and SLAP  will figure out  which on
C       is being used and act accordingly.
C
C       =================== S L A P Triad format ===================
C
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero   matrix  element is  placed  in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C       This routine requires  that the  matrix  A be  stored in the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C       5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C       1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Double Precision
C *Side Effects:
C       The SLAP Triad format (IA, JA,  A) is modified internally to
C       be the   SLAP Column  format.  See above.
C
C *See Also:
C       DCGS, DSDCGS
C***REFERENCES  1. P. Sonneveld, ``CGS, a fast Lanczos-type solver
C                 for nonsymmetric linear systems'', Delft University
C                 of Technology Report 84-16, Department of Math-
C                 ematics and Informatics, Julianalaan 132, 2628 BL
C                 Delft, Phone 015-784568.
C
C               2. E.F. Kaasschieter, ``The solution of non-symmetric
C                 linear systems by bi-conjugate gradients or conjugate
C                 gradients squared,''  Delft University of Tech-
C                 nology Report 86-21, Department of Mathematics and
C                 Informatics, Julianalaan 132, 2628 BL Delft,
C                 Phone 015-784568.
C***ROUTINES CALLED  DS2Y, DCHKW, DSILUS, DCGS, DSMV, DSLUI
C***END PROLOGUE  DSLUCS
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
      INTEGER IERR, IUNIT, LENW, IWORK(LENIW), LENIW
      DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW)
      EXTERNAL DSMV, DSLUI
      PARAMETER (LOCRB=1, LOCIB=11)
C
C         Change the SLAP input matrix IA, JA, A to SLAP-Column format.
C***FIRST EXECUTABLE STATEMENT  DSLUCS
      IERR = 0
      IF( N.LT.1 .OR. NELT.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      CALL DS2Y( N, NELT, IA, JA, A, ISYM )
C
C         Count number of Non-Zero elements preconditioner ILU matrix.
C         Then set up the work arrays.
      NL = 0
      NU = 0
      DO 20 ICOL = 1, N
C         Don't count diagonal.
         JBGN = JA(ICOL)+1
         JEND = JA(ICOL+1)-1
         IF( JBGN.LE.JEND ) THEN
CVD$ NOVECTOR
            DO 10 J = JBGN, JEND
               IF( IA(J).GT.ICOL ) THEN
                  NL = NL + 1
                  IF( ISYM.NE.0 ) NU = NU + 1
               ELSE
                  NU = NU + 1
               ENDIF
 10         CONTINUE
         ENDIF
 20   CONTINUE
C
      LOCIL = LOCIB
      LOCJL = LOCIL + N+1
      LOCIU = LOCJL + NL
      LOCJU = LOCIU + NU
      LOCNR = LOCJU + N+1
      LOCNC = LOCNR + N
      LOCIW = LOCNC + N
C
      LOCL   = LOCRB
      LOCDIN = LOCL + NL
      LOCUU  = LOCDIN + N
      LOCR   = LOCUU + NU
      LOCR0  = LOCR + N
      LOCP   = LOCR0 + N
      LOCQ   = LOCP + N
      LOCU   = LOCQ + N
      LOCV1  = LOCU + N
      LOCV2  = LOCV1 + N
      LOCW   = LOCV2 + N
C
C         Check the workspace allocations.
      CALL DCHKW( 'DSLUCS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR )
      IF( IERR.NE.0 ) RETURN
C
      IWORK(1) = LOCIL
      IWORK(2) = LOCJL
      IWORK(3) = LOCIU
      IWORK(4) = LOCJU
      IWORK(5) = LOCL
      IWORK(6) = LOCDIN
      IWORK(7) = LOCUU
      IWORK(9) = LOCIW
      IWORK(10) = LOCW
C
C         Compute the Incomplete LU decomposition.
      CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL),
     $     IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU),
     $     IWORK(LOCJU), RWORK(LOCUU), IWORK(LOCNR), IWORK(LOCNC) )
C
C         Perform the incomplete LU preconditioned
C         BiConjugate Gradient Squared algorithm.
      CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, DSMV,
     $     DSLUI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT,
     $     RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP),
     $     RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1),
     $     RWORK(LOCV2), RWORK, IWORK )
      RETURN
C------------- LAST LINE OF DSLUCS FOLLOWS ----------------------------
      END
*DECK ISDCGS
      FUNCTION ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U,
     $     V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM)
C***BEGIN PROLOGUE  ISDCGS
C***REFER TO  DCGS, DSDCGS, DSLUCS
C***DATE WRITTEN   890404   (YYMMDD)
C***REVISION DATE  890404   (YYMMDD)
C***CATEGORY NO.  D2A4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(ISDCGS-D),
C             Non-Symmetric Linear system, Sparse,
C             Iterative Precondition, Stop Test
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Preconditioned BiConjugate Gradient Stop Test.
C            This routine calculates the stop test for the BiConjugate
C            Gradient iteration scheme.  It returns a nonzero if the
C            error estimate (the type of which is determined by ITOL)
C            is less than the user specified tolerance TOL.
C***DESCRIPTION
C *Usage:
C     INTEGER  N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
C     INTEGER  IERR, IUNIT, IWORK(USER DEFINED)
C     DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), R0(N), P(N)
C     DOUBLE PRECISION Q(N), U(N), V1(N), V2(N)
C     DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM
C     EXTERNAL MATVEC, MSOLVE
C
C     IF( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL,
C    $     TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1,
C    $     V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
C    $     THEN ITERATION DONE
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Double Precision A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "LONG DESCRIPTION", in
C         the SLAP routine DCGS for more late breaking details...
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MATVEC :EXT      External.
C         Name of a routine which  performs the matrix vector multiply
C         operation  Y = A*X  given A and X.  The  name of  the MATVEC
C         routine must  be declared external  in the  calling program.
C         The calling sequence of MATVEC is:
C             CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A*X upon
C         return,  X is an input  vector.  NELT, IA,  JA,  A and  ISYM
C         define the SLAP matrix data structure: see LONG DESCRIPTION,
C         below.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R  for Z
C         given R with the preconditioning matrix M (M is supplied via
C         RWORK  and IWORK arrays).   The name  of  the MSOLVE routine
C         must be declared  external  in the  calling   program.   The
C         calling sequence of MSLOVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, R is  the right-hand side
C         vector, and Z is the solution upon return.  NELT,  IA, JA, A
C         and  ISYM define the SLAP  matrix  data structure: see  LONG
C         DESCRIPTION, below.  RWORK is a  double precision array that
C         can be used
C         to  pass   necessary  preconditioning     information and/or
C         workspace to MSOLVE.  IWORK is an integer work array for the
C         same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         This routine must calculate the residual from R = A*X - B.
C         This is un-natural and hence expensive for this type of iter-
C         ative method.  ITOL=2 is *STRONGLY* recommended.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than tol, where M-inv time a vector is the pre-
C         conditioning step.  This is the *NATURAL* stopping for this
C         iterative method and is *STRONGLY* recommended.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Error flag.  IERR is set to 3 if ITOL is not on of the
C         acceptable values, see above.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :IN       Double Precision R(N).
C         The residual r = b - Ax.
C R0     :WORK     Double Precision R0(N).
C P      :DUMMY    Double Precision P(N).
C Q      :DUMMY    Double Precision Q(N).
C U      :DUMMY    Double Precision U(N).
C V1     :DUMMY    Double Precision V1(N).
C V2     :WORK     Double Precision V2(N).
C         If ITOL.eq.1 then V2 is used to hold A * X - B on every call.
C         If ITOL.eq.2 then V2 is used to hold M-inv * B on the first
C         call.
C         If ITOL.eq.11 then V2 is used to X - SOLN.
C RWORK  :WORK     Double Precision RWORK(USER DEFINED).
C         Double Precision array that can be used for workspace in
C         MSOLVE.
C IWORK  :WORK     Integer IWORK(USER DEFINED).
C         Integer array that can be used for workspace in MSOLVE.
C AK     :IN       Double Precision.
C         Current iterate BiConjugate Gradient iteration parameter.
C BK     :IN       Double Precision.
C         Current iterate BiConjugate Gradient iteration parameter.
C BNRM   :INOUT    Double Precision.
C         Norm of the right hand side.  Type of norm depends on ITOL.
C         Calculated only on the first call.
C SOLNRM :INOUT    Double Precision.
C         2-Norm of the true solution, SOLN.  Only computed and used
C         if ITOL = 11.
C
C *Function Return Values:
C       0 : Error estimate (determined by ITOL) is *NOT* less than the
C           specified tolerance, TOL.  The iteration must continue.
C       1 : Error estimate (determined by ITOL) is less than the
C           specified tolerance, TOL.  The iteration can be considered
C           complete.
C
C *Precision:           Double Precision
C***REFERENCES  (NONE)
C***ROUTINES CALLED  MATVEC, MSOLVE, DNRM2
C***COMMON BLOCKS    SOLBLK
C***END PROLOGUE  ISDCGS
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
      INTEGER ITER, IERR, IUNIT, IWORK(1)
      DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N)
      DOUBLE PRECISION Q(N), U(N), V1(N), V2(N), RWORK(1)
      DOUBLE PRECISION AK, BK, BNRM, SOLNRM
      COMMON /SOLBLK/ SOLN(1)
      EXTERNAL MATVEC, MSOLVE
C
C***FIRST EXECUTABLE STATEMENT  ISDCGS
      ISDCGS = 0
C
      IF( ITOL.EQ.1 ) THEN
C         err = ||Residual||/||RightHandSide|| (2-Norms).
         IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1)
         CALL MATVEC(N, X, V2, NELT, IA, JA, A, ISYM )
         DO 5 I = 1, N
            V2(I) = V2(I) - B(I)
 5       CONTINUE
         ERR = DNRM2(N, V2, 1)/BNRM
      ELSE IF( ITOL.EQ.2 ) THEN
C                  -1              -1
C         err = ||M  Residual||/||M  RightHandSide|| (2-Norms).
         IF(ITER .EQ. 0) THEN
            CALL MSOLVE(N, B, V2, NELT, IA, JA, A, ISYM, RWORK, IWORK)
            BNRM = DNRM2(N, V2, 1)
         ENDIF
         ERR = DNRM2(N, R, 1)/BNRM
      ELSE IF( ITOL.EQ.11 ) THEN
C         err = ||x-TrueSolution||/||TrueSolution|| (2-Norms).
         IF(ITER .EQ. 0) SOLNRM = DNRM2(N, SOLN, 1)
         DO 10 I = 1, N
            V2(I) = X(I) - SOLN(I)
 10      CONTINUE
         ERR = DNRM2(N, V2, 1)/SOLNRM
      ELSE
C
C         If we get here ITOL is not one of the acceptable values.
         ERR = 1.0E10
         IERR = 3
      ENDIF
C
C         Print the error and Coeficients AK, BK on each step,
C         if desired.
      IF(IUNIT .NE. 0) THEN
         IF( ITER.EQ.0 ) THEN
            WRITE(IUNIT,1000) N, ITOL
         ENDIF
         WRITE(IUNIT,1010) ITER, ERR, AK, BK
      ENDIF
      IF(ERR .LE. TOL) ISDCGS = 1
C
      RETURN
 1000 FORMAT(' Preconditioned BiConjugate Gradient Squared for ',
     $     'N, ITOL = ',I5, I5,
     $     /' ITER','   Error Estimate','            Alpha',
     $     '             Beta')
 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7)
C------------- LAST LINE OF ISDCGS FOLLOWS ----------------------------
      END


C=======================================================================
C  MZ_IX_LEAFAREA, Subroutine
C
C  Simulates leaf area expansion and leaf senescence
C  Reference: Lizaso et al., 2003. Field Crops Research 80:1-17
C-----------------------------------------------------------------------
C  Revision history
C
C  1. Written                                       JIL        Aug 2001
C  2. Included SLA and C demand for leaf growth     JIL        Aug 2006
C  3. Modified and adapted for IXIM model           JIL        Sep 2007
C-----------------------------------------------------------------------
C  Called : GROSUB
C
C  Calls  :
C=======================================================================
      SUBROUTINE MZ_IX_LEAFAREA (DYNAMIC,                       !Control
     &   AX,LX,GDDAE,GROLF,ISTAGE,LFN,PAR,PHINT,PLTPOP,PATHSR,  !Input
     &   AGEFAC,FILES,SATFAC,PStres2,TURFAC,TEMPM,TLNO,XSTAGE,  !Input
     &   NSTRES,SWFAC,PLAE,                                     !Input
     &   GLA,LA,LAD,LAP,LATOT,LFL,LFWTD,LNEXP,PGROLF,PLAG,SEN,  !Output
     &   SENLA,YX)                                              !Output

      USE ModuleDefs
      IMPLICIT NONE
      SAVE

      REAL      A3
      REAL   	A4
      REAL      AGEFAC
      REAL      AK
      REAL      AX
      CHARACTER*80 C80
      REAL      CRLL
      INTEGER	DYNAMIC
      INTEGER   ERR
      CHARACTER*6     ERRKEY
      REAL      EXPONENT
      CHARACTER*92    FILECC
      CHARACTER*12    FILES
      INTEGER     FOUND
      REAL      GDDAE
      REAL      GLA(50)
      REAL      GR
      REAL      GROLF
      INTEGER	I
      INTEGER	IGDD
      REAL      II
      INTEGER   ISECT
      INTEGER   ISTAGE
      INTEGER   J
      INTEGER   JGDD
      REAL      JJ
      INTEGER   KGDD
      REAL      KK(50)
      REAL      LA(50)
      REAL      LAD(50)
      REAL      LAGR
      REAL      LAP(50)
      REAL      LATOT
      REAL      LEAFTT(50)
      REAL      LFCN(50)
      REAL      LFL(50)
      REAL      LFLGV
      INTEGER   LFN
      INTEGER   LFNOLD
      REAL      LFWT(50)
      REAL      LFWTD(50)
      REAL      LLX
      REAL      LM
      INTEGER   LNEXP
      INTEGER   LNUM
      INTEGER   LUNCRP
      REAL      LX
      REAL      NSTRES
      REAL      PAR
      CHARACTER*80    PATHSR
      REAL      PGROLF
      REAL      PHINT
      REAL      PLAE
      REAL      PLAG
      REAL      PLTPOP
      REAL      POPINT
      REAL      POPSLP
      REAL      PRED
      REAL      PStres2
      REAL      RLL
      REAL      SATFAC
      CHARACTER*6     SECTION
      REAL      SEN(50)
      REAL      SENGR
      REAL      SGR
      REAL      SWFAC
      REAL      LSLA(50)
      REAL      SLAINT
      REAL      SLAL
      REAL      SLAMN
      REAL      SLAMX
      REAL      SENLA
      REAL      SLASL
      REAL      SLASLP
      REAL      SLAX
      REAL      SRED
      REAL      TEMPM
      REAL      TLNO
      REAL      TRED
      REAL      TURFAC
      REAL      WK
      REAL      WLL
      REAL      XCK
      REAL      XSTAGE
      REAL      XZERO(50)
      REAL      XZEROS(50)
      REAL      YGDDAE
      REAL      YK
      REAL      YLL
      REAL      YX(50)
      REAL      YX1

C	DOUBLE PRECISION AX,LX

C ** JIL Inputs AX,LX read from cultivar file in MZ_IX_GROSUB

!----------------------------------------------------------------------
!                     DYNAMIC = RUNINIT
!----------------------------------------------------------------------

      IF(DYNAMIC.EQ.RUNINIT.OR.DYNAMIC.EQ.SEASINIT) THEN

!     ****************************************************************
!                     READ SPECIES FILE
!     ****************************************************************
      FILECC =  TRIM(PATHSR) // FILES
      CALL GETLUN('FILEC', LUNCRP)
      OPEN (LUNCRP,FILE = FILECC, STATUS = 'OLD',IOSTAT=ERR)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,0)

      SECTION = '*LEAF '
      CALL FIND(LUNCRP, SECTION, LNUM, FOUND)
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(3F8.3)',IOSTAT=ERR) A3,A4,AK
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(2F8.3)',IOSTAT=ERR) YK,YLL
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(3F8.3)',IOSTAT=ERR) SLAX,SLAMX,SLAMN
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

      ENDIF
      REWIND(LUNCRP)

      CLOSE (LUNCRP)

      CRLL      = 0.0
      GR        = 0.0
      I         = 0
      IGDD      = 0
      II        = 0.0
      J         = 0
      JGDD      = 0
      JJ        = 0.0
      KGDD      = 0
      LAGR      = 0.0
      LATOT     = 0.0
      LFLGV     = 0.0
      LFNOLD    = 50
      LLX       = 0.0
      LM        = 0.0
      LNEXP     = 0
      PGROLF    = 0.0
      PLAG      = 0.0
      POPINT    = 0.0
      POPSLP    = 0.0
      PRED      = 0.0
      RLL       = 0.0
      SENGR     = 0.0
      SGR       = 0.0
      SLASL     = 9.0 - 0.275*PLTPOP
      SLAINT    = 0.0
      SLAL      = 0.0
      SENLA     = 0.0
      SLASLP    = 0.0
      SRED      = 1.0
      TRED      = 1.0
      WK        = 0.0
      WLL       = 0.0
      XCK       = 1.0
      YGDDAE    = 1.0
      YX1       = 0.0

      DO I = 1,50
          KK(I)     = 0.0
          GLA(I)    = 0.0
          LA(I)     = 0.0
          LAD(I)    = 0.0
          LAP(I)    = 0.0
          LEAFTT(I) = 0.0
          LFCN(I)   = 0.0
          LFL(I)    = 0.0
          LFWT(I)   = 0.0
          LFWTD(I)  = 0.0
          LSLA(I)   = 0.0
          SEN(I)    = 0.0
          XZERO(I)  = 0.0
          XZEROS(I) = 0.0
          YX(I)     = 0.0
      ENDDO
      LA(1) = PLAE

!-----------------------------------------------------------------------
!                     DYNAMIC = INTEGR
!-----------------------------------------------------------------------
      ELSEIF(DYNAMIC.EQ.INTEGR) THEN

C *****************************************************************
C **                                                             **
C **                    LEAF EXPANSION SECTION                   **
C **                                                             **
C *****************************************************************

C ** Initializing variables

      IF (TLNO .NE. 0.0 .AND. LFNOLD .EQ. 50) THEN
         LFNOLD = LFN
         LFN = NINT(TLNO)
      ENDIF

      LM = 0.67 * LFN         !From Birch et al, 1998
      WK = LFN / 8.18
      IGDD = NINT(YGDDAE)
      JGDD = NINT(GDDAE)

      IF (JGDD .EQ. 0) THEN
        JGDD = 1
        CRLL = 0.0            !Initialization
      ENDIF

C ** Calculating leaf area expansion parameters

      IF (ISTAGE .LE. 3) THEN

C ** Temperature effect on leaf expansion
C    Calculated from Salah and Tardieu, 1996. J of Exp Bot 47:1689-1698

        IF (TEMPM .GT. 32.0) THEN
           TRED = 4.8 - 0.118*TEMPM
        ELSE
           TRED = 1.15*(1.0-EXP(-0.2*(TEMPM-9.8)))
        ENDIF
        TRED = AMIN1(TRED,1.0)
        TRED = AMAX1(TRED,1.E-8)   !JIL 03/03/2010

C ** Reducing leaf expansion due to water, oxygen, nitrogen or phosphorus stresses
C    Included PStres2 here
        SRED = AMIN1(TURFAC,(1-SATFAC),AGEFAC,PStres2)
        SRED = AMAX1(SRED,1.E-8)   !JIL 03/03/2010

        LATOT = 0.0
        PLAG = 0.0

        DO I=1,LFN

          II=REAL(I)
          YX(I)=1.016*AX*EXP((A3*((II-LM)/(LM-1))**2)
     &          +(A4*((II-LM)/(LM-1))**3))

C ** Reducing potential leaf size due to population density

          IF (PLTPOP .LE. 5.0) THEN
            IF (II .GT. LM) THEN
              PRED=1.0+0.115
     &                *EXP(-0.5*(((II/REAL(LFN))-0.876)/0.06)**2.0)
            ELSE
              PRED = 1.0
            ENDIF
          ELSE
            IF (II .LT. LM) THEN
              POPINT = 0.968+0.0005*PLTPOP
              POPSLP = -0.044+0.013*PLTPOP
            ELSE
              POPINT = 0.772+0.047*PLTPOP-0.0009*PLTPOP**2
              POPSLP = -0.4044+0.098*PLTPOP-0.0016*PLTPOP**2
            ENDIF

            PRED = POPINT-POPSLP*(II/REAL(LFN))
            PRED = AMIN1(PRED,1.0)
          ENDIF
          YX(I) = YX(I)*PRED

          KK(I) = YK+(AK*EXP(-((II-XCK)**2.0)/(2.0*WK**2.0)))
     &            + 0.031/(1.+EXP(-2.141*(II-LFN+0.5)))

          IF (I .LE. 2) THEN
           XZERO(I) = (2.0*(II - 1.0)) * 10.0   !  0, 20
          ELSE
           XZERO(I) = ((II-2.0) * PHINT + 8.0) + (2.197/KK(I))
          ENDIF

C ** Calculating individual leaf growth rate

         IF (LAP(I) .LT. YX(I)) THEN       !Leaf expanding
            LAGR = 0.0
            DO J=IGDD,JGDD
              JJ=REAL(J)

!             CHP 11/27/2007 getting overflows here -- put in a check
!             chp 8/5/2009 check low numbers, too.
              EXPONENT = -KK(I)*(JJ-XZERO(I))
              IF (EXPONENT > -40. .AND. EXPONENT < 40.) THEN
                GR = (YX(I)*KK(I))*((EXP(EXPONENT))/
     &             (1.0+EXP(EXPONENT))**2)
              ELSE
                GR = 0.0
              ENDIF

              IF (I .EQ. 1 .AND. J .EQ. 1) THEN
                GR = 0.6*YX(I)
              ENDIF
            LAGR = LAGR + GR
            END DO

            IF ((LAP(I)+LAGR) .GT. YX(I)) THEN
              LAGR = YX(I)-LAP(I)
            ENDIF

          ELSE                              !Leaf reached full size
            LAGR = 0.0
          ENDIF

C ** Calculating individual LA including stress & temperature and accumulating

          IF (I .LE. 5) THEN
            LAD(I)=LAGR*SRED
          ELSE
            LAD(I)=LAGR*AMIN1(SRED,TRED)
          ENDIF

          LA(I) = LA(I) + LAD(I)
          PLAG = PLAG + LAD(I)
          LAP(I) = LAP(I) + LAGR
          LATOT = LATOT + LA(I)

          IF (ISTAGE.LT.3.AND.LAP(I).EQ.YX(I).AND.LNEXP.LT.I) THEN
            LNEXP = I               !Leaf number that has completed expansion
          ENDIF

        END DO

        IF (JGDD .EQ. 1) THEN
          GROLF = PLAG / SLAX
        ENDIF

C ** Calculating individual leaf demand for biomass and nitrogen

C ** Effect of light on SLA
C    Calculated from Warrington and Norton, 1991. J Amer Soc Hort Sci 116:544-551.

        SLAL = 0.44+(1.9-0.46)*EXP(-0.165*PAR)
        PGROLF = 0.0
        DO I=1,LFN

C ** Effect of leaf position on SLA at today's light intensity
C    Calculated from Thiagarajah and Hunt, 1982. Can J Bot 60:1647-1652.
          LSLA(I) = SLAL * (SLAMN+(SLAMX-SLAMN) *
     &             EXP(-SLASL*(REAL(I)/REAL(LFN))))
          LSLA(I) = AMIN1(LSLA(I),SLAX)

C ** Effect of mean temperature on SLA
C    Calculated from Thiagarajah and Hunt, 1982. Can J Bot 60:1647-1652.
          IF (TEMPM .LT. 32.0) THEN
             SLAINT = (0.0003*TEMPM**2.0)-(0.0095*TEMPM)+1.0696
             SLASLP = 0.0222*TEMPM-0.8313

             LSLA(I) = LSLA(I)*(SLAINT+SLASLP*(REAL(I)/REAL(LFN)))
          ENDIF

C ** Individual leaf demand for biomass
!	    IF (LAD(I) .GT. 0.0) THEN
          IF (LAD(I) .GT. 1.E-9) THEN  !chp 08/10/09
            LFWTD(I) = LAD(I) / LSLA(I)    !Leaf biomass demand,g/leaf d

C	      LFND    = LFND + LFWTD(I)*0.05 !Leaf N demand, g N/plant
                                           !New leaf tissue target: 5% [N]
            LFWT(I) = LFWT(I)+LFWTD(I)     !For checking purposes only
          ELSE
            LFWTD(I) = 0.0
          ENDIF

C ** Potential leaf tissue growth, g/pl, used in NUPTAK for leaf N demand
          IF (I .LE. 5) THEN
            PGROLF = PGROLF+LFWTD(I)/SRED
          ELSE
            PGROLF = PGROLF+LFWTD(I)/AMIN1(SRED,TRED)
          ENDIF

        ENDDO

      ELSE
        PLAG   = 0.0
        PGROLF = 0.0
      ENDIF

C *****************************************************************
C **                                                             **
C **                    LEAF LONGEVITY SECTION                   **
C **                                                             **
C *****************************************************************

      LLX = 3.6 + (0.52*LFN)
      WLL = 0.35 * LFN
C
C ** JIL Accelerated senescence due to stresses
C
      IF (XSTAGE .LE. 3.0) THEN
        RLL=(1.0-AMIN1(SWFAC,(1-SATFAC),NSTRES,PStres2))*0.7
       ELSEIF (XSTAGE .LE. 4.5) THEN
        RLL=(1.0-AMIN1(AMAX1(SWFAC,0.5),(1-SATFAC),NSTRES,PStres2))*0.5
       ELSEIF (XSTAGE .LE. 5.5) THEN
        RLL=(1.0-AMIN1(AMAX1(SWFAC,0.5),(1-SATFAC),NSTRES,PStres2))*0.25
       ELSE
        RLL=(1.0-AMIN1(AMAX1(SWFAC,0.5),(1-SATFAC),NSTRES,PStres2))*0.01
      ENDIF

      DO I=1,LFN
         II=REAL(I)

C ** Initializing longevity of each leaf
         LFLGV = YLL + LX*EXP(-((II-LLX)**2.0)/(2.0*WLL**2.0))
         IF (LFL(I) .EQ. 0.0 .AND. SEN(1) .EQ. 0.0) THEN
            LFL(I) = LFLGV
         ENDIF
         IF (LFL(I) .EQ. 0.0 .AND. LFNOLD .LT. 50) THEN
            LFL(I) = LFLGV
         ENDIF

C ** Under stress reduce longevity
         IF (GDDAE .GT. XZERO(I)) THEN
         LFL(I)=LFL(I)-YLL*RLL
           LFL(I)=AMAX1(LFL(I),0.0)
         ENDIF

      END DO

C ** Longer longevity for remaining green leaf area after stress
!	IF (RLL .GT. 0.0) THEN
      IF (RLL .GT. 0.1) THEN
         CRLL = CRLL+RLL
        ELSEIF (CRLL .GT. 0.0) THEN
         IF (ISTAGE .GT. 3) THEN
           DO I=1,LFN
             IF (GLA(I) .GT. 0.0) THEN
                LFL(I) = LFL(I)+YLL*CRLL*0.6
             ENDIF
           ENDDO
           CRLL = 0.0
         ENDIF
 !	   CRLL = 0.0
      ENDIF
C
C *****************************************************************
C **                                                             **
C **                    LEAF SENESCENCE SECTION                  **
C **                                                             **
C *****************************************************************
C
C ** Calculating phenological leaf senescence
      SENLA = 0.0
      DO I=1,LFN
         YX1 = LA(I)
         XZEROS(I) = XZERO(I) + LFL(I)
         KGDD = IGDD - NINT(YLL*RLL)

         IF (SEN(I) .LT. LA(I)) THEN
           SENGR = 0.0
           DO J=KGDD,JGDD
             JJ=REAL(J)
!            CHP 11/27/2007 getting overflows here -- put in a check
             EXPONENT = -KK(I)*(JJ-XZEROS(I))
             IF (EXPONENT > -40. .AND. EXPONENT < 40.) THEN
               SGR = (YX1*KK(I))*((EXP(EXPONENT))/
     &             (1.0+EXP(EXPONENT))**2.)
             ELSE
               SGR = 0.0
             ENDIF

           SENGR = SENGR + SGR
           END DO
           IF ((SEN(I)+SENGR) .GT. LA(I)) THEN
             SENGR = LA(I)-SEN(I)
           ENDIF
         ELSE
           SENGR = 0.0
         ENDIF

         SEN(I) = SEN(I) + SENGR
         SENLA = SENLA + SEN(I)
         GLA(I) = LA(I) - SEN(I)

      END DO

      IF (SENLA .GT. LATOT) THEN
        SENLA = LATOT
      ENDIF

      YGDDAE = GDDAE

      ENDIF       !Endif for DYNAMIC LOOP

      RETURN

      END


! -*- F90 -*-

      function eksarp(x,v2,x1,x116,ptm,indpi)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      dimension ptm(10)

      z=v2
      xx=x-x1
      if (x.le.x116) then
         eksarp=ptm(1)+ptm(2)*z+ptm(3)*z**2+ptm(4)*xx+ptm(5)*xx**2
         else
            z1= log(x116/x1)
            xx1=x116-x1
            ff0=ptm(1)+ptm(2)*z1+ptm(3)*z1**2+ptm(4)*xx1+ptm(5)*xx1**2
            xx16=x-x116
            z16= log(x/x116)
            qexp=19.d0+(indpi-1)*(indpi-2)*8.d0/2.d0
            eksarp=ff0+ptm(6)*xx16+ptm(7)*xx16**2+ptm(8)*xx16**3        &
     &             +ptm(9)*xx16**qexp+ptm(10)*z16
      endif
   11 return
      END