c ART3D -An Analytical Tool for Modeling Coupled Reaction 
C in 3-Dimensional Groundwater Systems

        MODULE globaldata

	  SAVE

	  TYPE :: paramdata  ! data associated with each parameter
	    DOUBLE PRECISION :: start
	    DOUBLE PRECISION :: max
	    DOUBLE PRECISION :: min
	    DOUBLE PRECISION :: current   ! for stochastic sim
	    LOGICAL :: solve  ! solve for paramest, vary for stoch
	    INTEGER :: dist   ! distribution (0 = normal, 1 = linear) for stoch
	    DOUBLE PRECISION :: stddev  ! standard deviation for stoch, normal dist
	  END TYPE paramdata

	  TYPE :: obsptdata  ! data associated with each observation point
	    INTEGER :: id
	    CHARACTER :: name*50 !emrl changed from 20 to 50
	    DOUBLE PRECISION :: x
	    DOUBLE PRECISION :: y
	    DOUBLE PRECISION :: z
	    INTEGER :: numts  ! number of data points for each obs point
	  END TYPE obsptdata

	  TYPE :: griddata  ! data associated with the grid
	    INTEGER nx, ny, nz  ! number of cells in each direction
	    DOUBLE PRECISION originx, originy, originz ! origin of grid
	    DOUBLE PRECISION dx, dy, dz  ! length of cells in each direction
	            ! *** grid cells must all be the same size and shape
	  END TYPE griddata
	  TYPE(griddata) grid

	  INTEGER, SAVE :: numspecies = 0 ! number of species in model
	  CHARACTER, ALLOCATABLE, DIMENSION (:) :: name*20 ! names of species

	  INTEGER, SAVE :: numobs = 0  ! number of obs points
	  INTEGER :: nt  ! number of timesteps for grid
	  INTEGER :: numobsts  ! number of unique timesteps associated with the 
	                       ! obs points
	  INTEGER :: totalnumts ! total number of unique timesteps for grid and
	                  ! obs points.  Points will be solved at all these times
	  DOUBLE PRECISION :: tottime ! total time length of the model
	  
	  DOUBLE PRECISION, SAVE :: xsloc = 0 ! source location in x (always 0)
	  DOUBLE PRECISION, SAVE :: ysloc = 0 ! source location in y 
	                                      ! (always halfway)
	  DOUBLE PRECISION :: xsdim ! source dimension in x (always 0)
	  DOUBLE PRECISION :: ysdim ! source dimension in y 
	  DOUBLE PRECISION :: zsdim ! source dimension in z
	               ! stopping tolerances for parameter estimation
	  DOUBLE PRECISION :: abstol ! absolute function convergence tolerance
	  DOUBLE PRECISION :: reltol ! relative function convergence tolerance
	  INTEGER :: maxiter         ! max number of iterations
	  INTEGER :: maxfuncalls     ! max number of function calls

	  INTEGER :: stochruns       ! number of runs to be made in stoch mode

	  CHARACTER :: coveragename*36  ! GUID for coverage (GMS)

	  TYPE(obsptdata), ALLOCATABLE, DIMENSION (:) :: obspts ! array of obs pt 
	                                                        ! timesteps
	  TYPE(paramdata), ALLOCATABLE, DIMENSION(:) :: k !first order decay const
	  TYPE(paramdata), ALLOCATABLE, DIMENSION(:) :: Co !source concentrations
	  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: weight 
	        !2d array of weighting values for calculation of objective function
	  TYPE(paramdata), DIMENSION(7) :: aquiferdata
	                  ! aquiferdata(1) = retardation
	                  ! aquiferdata(2) = velocity
	                  ! aquiferdata(3) = alpha x (dispersion x)
	                  ! aquiferdata(4) = alpha y (dispersion y) - calculated by ART3D
	                  ! aquiferdata(5) = alpha z (dispersion z) - calculated by ART3D
	                  ! aquiferdata(6) = alpha y / alpha x (user input)
	                  ! aquiferdata(7) = alpha z / alpha x (user input)
	  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: yield 
	            ! array of yield coeffs
	  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: obsvalarray 
	            ! array of observed values for observation points
	  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: calcvalarray
	            ! array of calculated values for observation points
	  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: obstimearray
	            ! array of unique times for observe values
	  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: totaltimearray
	            ! array of unique times for obs points and grid
	  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: iterationarray
	            ! array to keep track of iteration parameter values for *.itr file

	  CONTAINS
	    SUBROUTINE AllocateMemory
	      IMPLICIT NONE
	      INTEGER err
	      ALLOCATE (k(numspecies), stat=err)
	      IF (err.NE.0) THEN
	        CALL ErrorMessageAndStop(2, '')
	      END IF
	      ALLOCATE (Co(numspecies), stat=err)
	      IF (err.NE.0) THEN
	        CALL ErrorMessageAndStop(2, '')
	      END IF
	    END SUBROUTINE AllocateMemory

	END MODULE globaldata
	  

	Program Art3d ! This is version 2, but after cleaning this up.
	Implicit None
	Double Precision work1(3073800) !200*100*50*9(nx*ny*nz*nespecies)
	Double Precision work2(3073800)
	Integer n,na,m,lda,lwork,nvec,mod
	Integer nx,ny,nz,nt,nn,nmax
	Character flname*256,tdata*256
	!cmh add new variables, data types, and file globals
	CHARACTER path*256, prefix*40, extension*3

	nmax=3073800 !dimension of work1 and work2
!     Number of Species	
      WRITE(*,*) 'ART3D (Version 1.0 beta)'
      WRITE(*,*) 'Analytical code for 3-Dimensional Reactive Transport'
      WRITE(*,*) 'For details contact: clement@ce.auburn.edu'
	WRITE(*,*) ' '
      WRITE(*,*) ' '
	flname(1:1) = ' '
	CALL getarg(1,flname) ! this will take the filename from GMS
	IF (flname(1:1).eq.' ') THEN
	  WRITE(*,*) 'Enter the name of your input data file:'
	  READ(*,'(A)') flname	
	END IF
	! cmh -- get the extension and read different file type if it is an art file
	CALL GetPathAndExtension(flname, path, prefix, extension)
	IF (extension == 'art') THEN
	  CALL RunFromGms(flname, path, prefix, extension)
	ELSE  ! if the extension is not .art, then we assume they want to run the 
	      ! original version with the original file format
	  OPEN(5,FILE=flname,FORM='FORMATTED',STATUS='unknown')
        READ (5,*) tdata
        READ (5,*) n,tdata
	  If (n < 1) then
	    write (*,*)"The numbers of Species must be more than 0"
	    stop
	  End if
        write (*,*) " "
        write (*,*) "Number of Species :", n
	  na=n
	  m=n
	  lda=n
	  lwork=n
	  nvec=1

!    Selection Mode (Batch or Transport)
	  Read (5,*) mod, tdata
	  If (mod==0) then
	  	Call Batch(n,na,m,lda,lwork,nvec)
        Else
	    Read (5,*) tdata
	!   Number of Nodos         
          READ (5,*) nx,ny,nz,nt,tdata
	    write(*,*) nx,ny,nz,nt
	    nn=nx*ny*nz*n
	    If(nn.GT.nmax)then
	      write (*,*) "increase nmax value to: ",nn
	      stop
	    end if
         Call Bcgms(nx,ny,nz,nt,n,na,m,lda,lwork,nvec,work1(1),work2(1))
	  end if
	END IF
	WRITE(*,*) "Simulation completed successfully."
	WRITE(*,*) "Press Enter"
	READ(*,*)
	STOP
	END PROGRAM

	SUBROUTINE GetPathAndExtension (flname, path, prefix, extension)
	   ! given the entire filename, return the path, prefix and extension as separate strings
	IMPLICIT NONE
	CHARACTER, INTENT(IN) :: flname*256
	CHARACTER, INTENT(OUT) :: prefix*40
	CHARACTER :: temp*256
	CHARACTER, INTENT(OUT) :: path*256
	CHARACTER, INTENT(OUT) :: extension*3
	INTEGER i, j, numslashes

	numslashes = 0;
	temp = flname
	i = 1
	DO WHILE (i < 256) 
	  IF (temp(i:i) == '\') THEN
	    numslashes = numslashes + 1
	  END IF
	  i = i + 1
	END DO
	i = 1
	j = 0
	DO WHILE ( i < numslashes+1)
	  j = j + 1
	  IF (temp(j:j) == '\') THEN
	    i = i + 1
	  END IF
	END DO
	path(1:256) = temp(1:j-1)
	temp(1:256) = temp(j+1:256)
	j = 1
	i = 1
	DO WHILE (temp(j:j) /= '.')
	  j = j + 1
	END DO
	prefix(1:40) = temp(1:j-1)
	extension(1:3) = temp(j+1:j+4)


	END SUBROUTINE

	SUBROUTINE RunFromGMS (flname, path, prefix, extension)
	! cmh - read art file type and run according to GMS options
	USE globaldata
	IMPLICIT NONE
	CHARACTER :: flname*256, path*256
	CHARACTER, INTENT(IN) :: prefix*40
	CHARACTER, INTENT(IN) :: extension*3
	CHARACTER card*10,gridfilename*256,param*20,namewpath*256
	CHARACTER, ALLOCATABLE, DIMENSION(:) :: paramlist*10
	INTEGER err, i, j, id, count, kount, pathlen, prelen
	INTEGER simtype ! 0=normal run, 1= param est, 2=stochastic
	INTEGER LIV, LV, P, rowcount, numparam
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IV
	INTEGER, DIMENSION(1) :: UIPARM
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: D, X, V
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: B
	DOUBLE PRECISION, DIMENSION(1) :: URPARM
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: tempvalarray
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: temptimearray
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: a
	DOUBLE PRECISION dummy, val, dt
	DOUBLE PRECISION time
	DOUBLE PRECISION FX
	LOGICAL SearchArray, exists


	EXTERNAL MNFB, IVSET, CALCF, UFPARM

	! first read in data from *.art file
	OPEN(5,FILE=flname,FORM='FORMATTED',STATUS='unknown',IOSTAT = err)
	IF (err.NE.0) THEN
	  CALL ErrorMessageAndStop(1, '')
	END IF
	READ(5, *, IOSTAT = err) card
	IF (card /= 'ART3D'.OR.err /= 0) THEN  ! file must begin with ART3D
	  CALL ErrorMessageAndStop(3, '')
	END IF
	READ (5,*,IOSTAT = err) card
	DO WHILE (err /= -1)  ! loop until all lines of file are read
	  IF (err /= 0) THEN
	    CALL ErrorMessageAndStop(4, card)
	  END IF
	  IF (card == 'GRIDFILE') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT = err) card, gridfilename  ! get name of gridfile
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(4, card)
	    END IF
	    pathlen = LEN_TRIM(path)
	    namewpath = path(1:pathlen)//'\'//gridfilename
	    OPEN(6, FILE=namewpath, FORM='FORMATTED', STATUS='unknown',
     $	     IOSTAT=err)   ! get necessary data from the gridfile
	    IF (err /=0) THEN
	      CALL ErrorMessageAndStop(5, '')
	    END IF
	    READ (6,*,IOSTAT = err) card
	    DO WHILE (err==0)
	      IF (card == 'ORIGIN') THEN  ! get origin of grid
	        BACKSPACE(6)
	        READ (6,*,IOSTAT = err) card, grid%originx, grid%originy, 
     $                                grid%originz
	        IF (err/=0) THEN
	          CALL ErrorMessageAndStop(6, card) ! ORIGIN card error
	        ENDIF
	      ELSE IF (card == 'DIM') THEN  ! get dimension data
	        BACKSPACE(6)
	        READ (6,*,IOSTAT = err) card, grid%nx, grid%ny, grid%nz
	        IF (err/=0) THEN
    	          CALL ErrorMessageAndStop(6, card) ! DIM card error
	        ENDIF
	        READ (6,*,IOSTAT = err) dummy
    	        IF (err/=0) THEN
	          CALL ErrorMessageAndStop(6, card) ! DIM card error
	        ENDIF
	        READ (6,*,IOSTAT = err) val
    	        IF (err/=0) THEN
	          CALL ErrorMessageAndStop(6, card) ! DIM card error
    	        ENDIF
	        grid%dx = val      !dx value
	        DO WHILE (val /= 0.0) 
    	        READ (6,*,IOSTAT = err) val
    	        IF (err/=0) THEN
	          CALL ErrorMessageAndStop(6, card) ! gridfile error 
	        END IF
	        END DO
	        READ (6,*,IOSTAT = err) val
	        IF (err/=0) THEN
	          CALL ErrorMessageAndStop(6, card) ! gridfile error
	        END IF
    	        grid%dy = val   !dy value
	        DO WHILE (val /= 0.0)
    	          READ (6,*,IOSTAT = err) val
	          IF (err/=0) THEN
	            CALL ErrorMessageAndStop(6, card) ! gridfile error
    	          END IF
	        END DO
	        READ (6,*,IOSTAT = err) val
        	    IF (err/=0) THEN
	          CALL ErrorMessageAndStop(6, card) ! gridfile error
	        END IF
	        grid%dz = val   !dz value
	      END IF
	      READ (6,*,IOSTAT = err) card
	      IF (err /= 0.AND.err /= -1) THEN !IOSTAT = -1 means end of file
	        CALL ErrorMessageAndStop(6, card)
	      END IF
	    END DO
	    CLOSE(6)
	  ELSE IF (card == 'OBSCOV') THEN
	    BACKSPACE(5)
	    READ(5, *, IOSTAT=err) card, coveragename  ! get GUID for coverage
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'SOURCE') THEN
	    BACKSPACE(5)
	    READ(5, *, IOSTAT=err) card, ysdim, zsdim  !source dimensions
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'NUMSPEC') THEN
	    BACKSPACE(5)
	    READ(5, *, IOSTAT=err) card, numspecies  ! number of species
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'SPECNAMES') THEN
	    ALLOCATE (name(numspecies), STAT = err)
	    IF (err.NE.0) THEN
	      CALL ErrorMessageAndStop(2,'')
	    END IF
	    BACKSPACE(5)
	    READ(5, *, IOSTAT=err) card, (name(i), i=1,numspecies) 
	                             !names of the species
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'YIELD') THEN
	    ALLOCATE(yield(numspecies, numspecies), STAT = err)
	    IF (err.NE.0) THEN
	      CALL ErrorMessageAndStop(2, '')
	    END IF
	    i = 1
	    DO i = 1,numspecies
	      READ(5,*,IOSTAT=err) (yield(i,j), j=1,numspecies) ! yield matrix
	      IF (err /= 0) THEN
	        CALL ErrorMessageAndStop(6, card)
	      END IF
	    END DO
	  ELSE IF (card == 'TIME') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, tottime, nt
	    IF (err.NE.0) THEN
	      CALL ErrorMessageAndStop(4, card)
	    END IF
	  ELSE IF (card == 'SIMTYPE') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, simtype ! 0 = normal forward run,
	                                       ! 1 = parameter est. mode,
	                                       ! 2 = stochastic mode
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'STOCH') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, stochruns  !num of stochastic runs
	                                  ! this card is only included if simtype = 2
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'MAXITER') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, maxiter  ! max number of iterations 
	                                  ! this card only used if simtype = 1
	    IF (err /=0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'MAXFUNCALL') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, maxfuncalls  ! max number of function calls 
	                                  ! this card only used if simtype = 1
	    IF (err /=0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'ABSTOL') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, abstol  ! abs function converg tolerance 
	                                  ! this card only used if simtype = 1
	    IF (err /=0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'RELTOL') THEN
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, reltol  ! abs function converg tolerance 
	                                  ! this card only used if simtype = 1
	    IF (err /=0) THEN
	      CALL ErrorMessageAndStop(6, card)
	    END IF
	  ELSE IF (card == 'PARAM') THEN  
	    IF (ALLOCATED(k).AND.ALLOCATED(Co)) THEN
	    ELSE
	      CALL AllocateMemory ! now that we know the number of species we can 
	                          ! allocate the memory for the arrays
	    END IF
	    BACKSPACE(5)
	    READ(5,*,IOSTAT=err) card, param
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(7, param)
	    END IF
	    BACKSPACE(5)
	    IF (simtype == 0) THEN  
		                ! input for normal run includes only the start value
	      IF (param == 'retard') THEN  ! retardation value
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(1)%start 
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	      ELSE IF(param == 'velocity') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(2)%start 
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	      ELSE IF (param == 'alphax') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(3)%start
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	      ELSE IF (param == 'alphayratio') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(6)%start 
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	      ELSE IF (param == 'alphazratio') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(7)%start 
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	      ELSE IF (param(1:1) == 'k') THEN ! k values for each specie
	        DO i=1,numspecies
	          IF (param(2:20) == name(i)) THEN
	            READ(5,*,IOSTAT=err) card, param, k(i)%start
	            IF (err /= 0) THEN
	              CALL ErrorMessageAndStop(7, param)
	            END IF
	          END IF
	        END DO
	      ELSE IF (param(1:1) == 'c') THEN  !Co values for each specie
	        DO i=1,numspecies
	          IF (param(2:20) == name(i)) THEN
	            READ(5,*,IOSTAT=err) card, param, Co(i)%start
	            IF (err /= 0) THEN
	              CALL ErrorMessageAndStop(7, param)
	            END IF
	          END IF
	        END DO
	      END IF
	    ELSE IF (simtype == 2) THEN  ! input for stochastic runs inludes 
	                                 ! start, min and max values, solve (a boolean
	                                 ! which is true if the parameter is to be varied), 
	                                 ! dist (0=normal, 1 = linear distribution), 
	                                 ! stddev (standard deviation)
	      IF (param == 'retard') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(1)%start, 
     $             aquiferdata(1)%min, aquiferdata(1)%max, 
     $             aquiferdata(1)%solve, aquiferdata(1)%dist, 
     $             aquiferdata(1)%stddev
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(1)%solve .AND.  ! check that min < start < max
     $            (aquiferdata(1)%min > aquiferdata(1)%start .OR.
     $            aquiferdata(1)%max < aquiferdata(1)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF(param == 'velocity') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(2)%start, 
     $             aquiferdata(2)%min, aquiferdata(2)%max, 
     $             aquiferdata(2)%solve, aquiferdata(2)%dist, 
     $             aquiferdata(2)%stddev
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(2)%solve .AND.  ! check that min < start < max
     $             (aquiferdata(2)%min > aquiferdata(2)%start .OR.
     $            aquiferdata(2)%max < aquiferdata(2)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param == 'alphax') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(3)%start, 
     $             aquiferdata(3)%min, aquiferdata(3)%max, 
     $             aquiferdata(3)%solve, aquiferdata(3)%dist, 
     $             aquiferdata(3)%stddev
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(3)%solve .AND.  ! check that min < start < max
     $            (aquiferdata(3)%min > aquiferdata(3)%start .OR.
     $            aquiferdata(3)%max < aquiferdata(3)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param == 'alphayratio') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(6)%start, 
     $             aquiferdata(6)%min, aquiferdata(6)%max, 
     $             aquiferdata(6)%solve, aquiferdata(6)%dist, 
     $             aquiferdata(6)%stddev
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(6)%solve .AND.  ! check that min < start < max
     $            (aquiferdata(6)%min > aquiferdata(6)%start .OR.
     $            aquiferdata(6)%max < aquiferdata(6)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param == 'alphazratio') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(7)%start, 
     $             aquiferdata(7)%min, aquiferdata(7)%max, 
     $             aquiferdata(7)%solve, aquiferdata(7)%dist, 
     $             aquiferdata(7)%stddev
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(7)%solve .AND.  ! check that min < start < max
     $            (aquiferdata(7)%min > aquiferdata(7)%start .OR.
     $            aquiferdata(7)%max < aquiferdata(7)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param(1:1) == 'k') THEN ! k values for each specie
	        DO i=1,numspecies
	          IF (param(2:20) == name(i)) THEN
	            READ(5,*,IOSTAT=err) card, param, k(i)%start, k(i)%min,
     $                 k(i)%max, k(i)%solve, k(i)%dist, k(i)%stddev
	            IF (err /= 0) THEN
	              CALL ErrorMessageAndStop(7, param)
	            END IF
	            IF (k(i)%solve .AND. (k(i)%min > k(i)%start .OR.
     $                k(i)%max < k(i)%start)) THEN !check that min < start < max
	              CALL ErrorMessageAndStop(11, param)
	            END IF
	          END IF
	        END DO
	      ELSE IF (param(1:1) == 'c') THEN  ! Co values for each specie
	        DO i=1,numspecies
	          IF (param(2:20) == name(i)) THEN
	            READ(5,*,IOSTAT=err) card, param, Co(i)%start, 
     $                 Co(i)%min,Co(i)%max, Co(i)%solve, Co(i)%dist, 
     $                 Co(i)%stddev
	            IF (err /= 0) THEN
	              CALL ErrorMessageAndStop(7, param)
	            END IF
	            IF (Co(i)%solve .AND. (Co(i)%min > Co(i)%start .OR.
     $                Co(i)%max < Co(i)%start)) THEN  !check that min<start<max
	              CALL ErrorMessageAndStop(11, param)
	            END IF
	          END IF
	        END DO
	      END IF
	    ELSE IF (simtype == 1) THEN ! parameter estimation mode input includes
                                      ! start, min and max values and 
	                                ! solve (a boolean: TRUE means that the parameter will be
	                                ! solved for in the parameter estimation)
	      IF (param == 'retard') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(1)%start, 
     $             aquiferdata(1)%min, aquiferdata(1)%max, 
     $             aquiferdata(1)%solve
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(1)%solve .AND. ! check that min < start < max
     $            (aquiferdata(1)%min > aquiferdata(1)%start .OR.
     $            aquiferdata(1)%max < aquiferdata(1)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF(param == 'velocity') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(2)%start, 
     $             aquiferdata(2)%min, aquiferdata(2)%max, 
     $             aquiferdata(2)%solve
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(2)%solve .AND. ! check that min < start < max
     $            (aquiferdata(2)%min > aquiferdata(2)%start .OR.
     $            aquiferdata(2)%max < aquiferdata(2)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param == 'alphax') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(3)%start, 
     $             aquiferdata(3)%min, aquiferdata(3)%max, 
     $             aquiferdata(3)%solve
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(3)%solve .AND. ! check that min < start < max
     $            (aquiferdata(3)%min > aquiferdata(3)%start .OR.
     $            aquiferdata(3)%max < aquiferdata(3)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param == 'alphayratio') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(6)%start, 
     $             aquiferdata(6)%min, aquiferdata(6)%max, 
     $             aquiferdata(6)%solve
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(6)%solve .AND. ! check that min < start < max
     $            (aquiferdata(6)%min > aquiferdata(6)%start .OR.
     $            aquiferdata(6)%max < aquiferdata(6)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param == 'alphazratio') THEN
	        READ(5,*,IOSTAT=err) card, param, aquiferdata(7)%start, 
     $             aquiferdata(7)%min, aquiferdata(7)%max, 
     $             aquiferdata(7)%solve
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(7, param)
	        END IF
	        IF (aquiferdata(7)%solve .AND. ! check that min < start < max
     $            (aquiferdata(7)%min > aquiferdata(7)%start .OR.
     $            aquiferdata(7)%max < aquiferdata(7)%start)) THEN
	          CALL ErrorMessageAndStop(11, param)
	        END IF
	      ELSE IF (param(1:1) == 'k') THEN  ! k values for each specie
	        DO i=1,numspecies
	          IF (param(2:20) == name(i)) THEN
	            READ(5,*,IOSTAT=err) card, param, k(i)%start, k(i)%min,
     $                 k(i)%max, k(i)%solve
	            IF (err /= 0) THEN
	              CALL ErrorMessageAndStop(7, param)
	            END IF
	            IF (k(i)%solve .AND. (k(i)%min > k(i)%start .OR.
     $                k(i)%max < k(i)%start)) THEN ! check that min<start<max
	              CALL ErrorMessageAndStop(11, param)
	            END IF
	          END IF
	        END DO
	      ELSE IF (param(1:1) == 'c') THEN ! Co values for each specie
	        DO i=1,numspecies
	          IF (param(2:20) == name(i)) THEN
	            READ(5,*,IOSTAT=err) card, param, Co(i)%start, 
     $                 Co(i)%min, Co(i)%max, Co(i)%solve
	            IF (err /= 0) THEN
	              CALL ErrorMessageAndStop(7, param)
	            END IF
	            IF (Co(i)%solve .AND. (Co(i)%min > Co(i)%start .OR.
     $                Co(i)%max < Co(i)%start)) THEN ! check that min<start<max
	              CALL ErrorMessageAndStop(11, param)
	            END IF
	          END IF
	        END DO
	      END IF
	    END IF
	  ELSE IF (card == 'NOBS') THEN
	    BACKSPACE(5)
	    READ(5,*, IOSTAT=err) card, numobs
	    IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(7, param)
	    END IF
	  ELSE IF (card == 'WEIGHT') THEN ! weight card
	    ALLOCATE (weight(numspecies, numobs), stat=err)
	    IF (err.NE.0) THEN
	      CALL ErrorMessageAndStop(2, '')
	    END IF
	    DO j=1,numobs
	      READ(5,*,IOSTAT=err) (weight(i,j), i=1,numspecies)
	           ! one weight value for each specie and for each point
			   ! - only for parameter estimation
	      IF (err /= 0) THEN
	        CALL ErrorMessageAndStop(7, param)
	      END IF
	    END DO
	  ELSE IF (card == 'OBS') THEN
	    ALLOCATE (tempvalarray(numspecies))
	    numobsts = 0
	    BACKSPACE(5)
	    IF (numobs > 0) THEN
	      ALLOCATE(obspts(numobs),STAT=err) 
		  ! now that we know how many obs points there are, 
		  ! we can allocate the obspts array
	      IF (err /= 0) THEN
	        CALL ErrorMessageAndStop(2, '')
	      END IF
	    END IF
	    rowcount = 0
	    DO i=1,numobs ! the following lines are only read if there is 
		              ! at least one obs pt
	      ! this first loop through the OBS cards is only to get the
	      ! characteristics of the observation points and the time
		  ! values 
	      READ(5,*,IOSTAT=err) card, obspts(i)%id, obspts(i)%name,  
     $           obspts(i)%x, obspts(i)%y, obspts(i)%z, obspts(i)%numts
	      rowcount = rowcount + 1
	      IF (err /= 0) THEN
	        CALL ErrorMessageAndStop(4, card)
	      END IF
	      DO j = 1, obspts(i)%numts
	        id = id + 1
	        READ(5,*,IOSTAT=err) time, 
     $             (tempvalarray(count), count=1,numspecies)
	        rowcount = rowcount + 1
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(4, card)
	        END IF
	        IF (numobsts > 0) THEN  ! we don't want any duplicates in the time 
			                        ! array so we search the array first
	          exists = SearchArray (obstimearray, numobsts, time)
	        ELSE
	          exists = .FALSE.
	        END IF
	        IF (.NOT.exists) THEN ! this annoying loop does what C can do with 
			                      ! a single realloc command (sigh)
	          ALLOCATE (temptimearray(numobsts))
	          DO count = 1, numobsts
	            temptimearray(count) = obstimearray(count) !copy to temp array
	          END DO
	          IF (ALLOCATED(obstimearray)) DEALLOCATE(obstimearray) 
			                                                  ! free array
	          numobsts = numobsts + 1
	          ALLOCATE (obstimearray(numobsts)) 
			                            ! realloc array with new size
	          DO count = 1, (numobsts-1)
	            obstimearray(count) = temptimearray(count) 
				                                    ! copy the temp array back over
	          END DO
	          IF (ALLOCATED(temptimearray))DEALLOCATE (temptimearray)
	          obstimearray(numobsts) = time  
			                         ! add the new value at the end of the array
	        END IF
	      END DO
	    END DO
	    IF (numobsts > 0) THEN
	      CALL SortArray(obstimearray, numobsts) ! put the array in order
	                      ! this makes the output nicer
	    END IF
	    IF (numobs > 0) THEN
	      ALLOCATE (obsvalarray(numobs,numobsts,numspecies))
	      DO i = 1, numobs
	        DO j = 1, numobsts
	          DO kount = 1, numspecies
	               ! if there was no observation made, the value will be -999
	            obsvalarray(i,j,kount) = -999
	          END DO
	        END DO
	      END DO
	    END IF
	    DO i = 1, rowcount 
	      BACKSPACE (5)
	    END DO
	    DO i=1,numobs 
	      ! this second loop through the OBS cards is to fill in the
	      ! observed concentration values
	      READ(5,*,IOSTAT=err) card
	      IF (err /= 0) THEN
	        CALL ErrorMessageAndStop(4, card)
	      END IF
	      DO j = 1, obspts(i)%numts
	        READ(5,*,IOSTAT=err) time, 
     $             (tempvalarray(count), count=1,numspecies)
	        IF (err /= 0) THEN
	          CALL ErrorMessageAndStop(4, card)
	        END IF
	        DO count = 1, numobsts
	          IF (obstimearray(count) == time) THEN
	            EXIT
	          END IF
	        END DO
	        DO kount = 1, numspecies
	          obsvalarray(i,count,kount) = tempvalarray(kount)
	        END DO
	      END DO
	    END DO
	  END IF
	  READ (5,*,IOSTAT = err) card ! read the next line and loop through again
	  IF (err /= 0.AND.err /= -1) THEN !IOSTAT = -1 means end of file
	    CALL ErrorMessageAndStop(4, card)
	  END IF
	END DO
	CLOSE(5) ! done reading in data

	  ! now add the grid time step times to the time array

	dt = tottime/nt  ! all grid timesteps are equally sized
	totalnumts = numobsts
	ALLOCATE (totaltimearray(numobsts))
	DO i = 1, numobsts
	  totaltimearray(i) = obstimearray(i) ! copy over the obs timesteps
	END DO
	DO i = 1, nt
	  time = i*dt ! grid timestep
	  exists = SearchArray (totaltimearray, totalnumts, time)
	  IF (.NOT.exists) THEN  ! once again it takes FORTRAN 13 lines to do what 
	                         ! C can do in 1 - reallocate an array slightly larger
	    IF (ALLOCATED(temptimearray)) DEALLOCATE(temptimearray)
	    ALLOCATE (temptimearray(totalnumts))
	    DO count = 1, totalnumts
	      temptimearray(count) = totaltimearray(count)
	    END DO
	    IF (ALLOCATED(totaltimearray)) DEALLOCATE(totaltimearray)
	    totalnumts = totalnumts + 1
	    ALLOCATE (totaltimearray(totalnumts))
	    DO count = 1, (totalnumts-1)
	      totaltimearray(count) = temptimearray(count)
	    END DO
	    IF (ALLOCATED(temptimearray))DEALLOCATE (temptimearray)
	    totaltimearray(totalnumts) = time
	  END IF
	END DO

	ALLOCATE (calcvalarray(numobs,totalnumts,numspecies))
	    ! sort the array so the time steps are in order
	CALL SortArray(totaltimearray, totalnumts)

	ALLOCATE (a(numspecies,numspecies), STAT=err)
	IF (err /= 0) THEN
	  CALL ErrorMessageAndStop(2, '')
	END IF
	
	IF (simtype == 0) THEN ! normal forward run
	  CALL GetCurrentData()
	  CALL FinalDataTweaking(a)
	  CALL ForwardRun(path, prefix, extension, a, 0, .TRUE.)
	  CALL WriteOutputFile(simtype, path, prefix)

	ELSE IF (simtype == 2) THEN !stochastic run
	  prelen = LEN_TRIM(prefix)
	  flname = path(1:pathlen)//'\'//prefix(1:prelen)//'.itr'
	     ! prepare to write *.itr file which lists all the random values
	  OPEN(17,FILE=flname,FORM='FORMATTED',STATUS='unknown')
	  WRITE (17,'(A20)') 'ART3D Iteration File'
	     ! count the number of parameters to be varied
	  count = 0
	  DO i = 1, 3
	    IF (aquiferdata(i)%solve) THEN 
		  count = count + 1
	    END IF
	  END DO
	  DO i = 6, 7
	    IF (aquiferdata(i)%solve) THEN 
	      count = count + 1
	    END IF
	  END DO
	  DO i = 1, numspecies
	    IF (k(i)%solve) THEN 
		  count = count + 1
	    END IF
	    IF (Co(i)%solve) THEN 
		  count = count + 1
	    END IF
	  END DO
	   ! make a list of the names of the parameters to be varied
	  ALLOCATE (paramlist(count))
	  count = 1
	  IF (aquiferdata(1)%solve) THEN 
	    paramlist(count) = 'retard'
	    count = count + 1
	  END IF
	  IF (aquiferdata(2)%solve) THEN
	    paramlist(count) = 'velocity'
	    count = count + 1
	  END IF
	  IF (aquiferdata(3)%solve) THEN
	    paramlist(count) = 'alphax'
	    count = count + 1
	  END IF
	  IF (aquiferdata(6)%solve) THEN
	    paramlist(count) = 'alphay/alphax'
	    count = count + 1
	  END IF
	  IF (aquiferdata(7)%solve) THEN
	    paramlist(count) = 'alphaz/alphax'
	    count = count + 1
	  END IF
	  DO i = 1, numspecies
	    IF (k(i)%solve) THEN
	      paramlist(count) = 'k_'//name(i)
	      count = count + 1
	    END IF
	  END DO
	  DO i = 1, numspecies
	    IF (Co(i)%solve) THEN
	      paramlist(count) = 'Co_'//name(i)
	      count = count + 1
	    END IF
	  END DO
	  numparam = count - 1
	  WRITE (17,33) 'Run', (paramlist(i), i = 1, numparam)
	              ! write headers for *.itr file
33	  FORMAT (A5, 25A12)
	  DO i = 1, stochruns  ! run the user-specified number of times
	    CALL GetRandomData()  ! monte-carlo method
	    CALL PrintStochasticData(i, numparam)  ! print the random values to 
		                            ! the screen and to the *.itr file
	    CALL FinalDataTweaking(a)  
	    CALL ForwardRun(path, prefix, extension, a, i, .TRUE.)
	  END DO
	  CLOSE (17)
	  CALL WriteOutputFile(simtype, path, prefix)
	ELSE IF (simtype == 1) THEN !parameter estimation run
	 ! for information on how the PORT library (by David M. Gay) works see:
	 ! http://netlib.bell-labs.com/cm/cs/cstr/153.pdf
	! find out how many variables are to be solved for
	  P = 0
	  DO i = 1,3
	    IF (aquiferdata(i)%solve) THEN
	      P = P + 1
	    END IF
	  END DO
	  DO i = 6,7
	    IF (aquiferdata(i)%solve) THEN
	      P = P + 1
	    END IF
	  END DO
	  DO i = 1, numspecies
	    IF (k(i)%solve) THEN
	      P = P + 1
	    END IF
	    IF (Co(i)%solve) THEN
	      P = P + 1
	    END IF
	  END DO
	! allocate the arrays and vectors for PORT library
	  LV = 200+(P*(P+17)/2) ! size of array V
	  LIV = 256              ! size of array IV
	  ALLOCATE (V(LV))  ! an array of a lot of floating  point values needed 
	                    ! to run the PORT library
	  ALLOCATE (IV(LIV)) ! an array of a lot of integers needed to run the
	                     ! PORT library
	  ALLOCATE (X(P))    ! an array of parameter values - these are changed in 
	                     ! each iteration
	  ALLOCATE (B(2,P))  ! an array of the upper and lower bounds for each 
	                     ! parameter
	  ALLOCATE (D(P))    ! a scale vector 
	         !(see pg 5 of http://netlib.bell-labs.com/cm/cs/cstr/153.pdf)
	  CALL DIVSET(2, IV, LIV, LV, V)
	                 ! this will set everything to default values.  Then we will
	                 ! change the four values below to user-defined values
	  V(31) = abstol ! V(AFCTOL) - absolute function covergence tolerance
	  V(32) = reltol ! V(RFCTOL) - relative function covergence tolerance
	  IV (18) = maxiter ! IV(MXITER) - maximum # of iterations
	  IV (17) = maxfuncalls ! IV(MXFCAL) - maximum # of function calls
c	  V(33) = .0001  ! IV(XCTOL) - X-convergence

	! set current values
	  DO i = 1, 7
	    aquiferdata(i)%current = aquiferdata(i)%start
	  END DO
	  DO i = 1, numspecies
	    k(i)%current = k(i)%start
	    Co(i)%current = Co(i)%start
	  END DO
	! set the B, X and D arrays
	  count = 1
	  DO j = 1, 3
	    IF (aquiferdata(j)%solve) THEN
	      B(1,count) = aquiferdata(j)%min ! lower bound
	      B(2,count) = aquiferdata(j)%max ! upper bound
	      X(count) = aquiferdata(j)%current ! current parameter value
	      IF (X(count) /= 0.0) THEN
	                 ! D will just be the inverse of each parameter value
	                 ! but the whole thing will blow up if X is zero, so we need the following
		    D(count) = 1/X(count)  
	      ELSE
	        D(count) = 0.00000001
	      END IF
	      count = count + 1
	    END IF
	  END DO
	  DO j = 6, 7 ! same as previous do loop
	    IF (aquiferdata(j)%solve) THEN
	      B(1,count) = aquiferdata(j)%min
	      B(2,count) = aquiferdata(j)%max
	      X(count) = aquiferdata(j)%current
	      IF (X(count) /= 0.0) THEN
		    D(count) = 1/X(count)
	      ELSE
	        D(count) = 0.00000001
	      END IF
	      count = count + 1
	    END IF
	  END DO
	  DO j = 1, numspecies ! same as previous do loop
	    IF (k(j)%solve) THEN
	      B(1,count) = k(j)%min
	      B(2,count) = k(j)%max
	      X(count) = k(j)%current
	      IF (X(count) /= 0.0) THEN
		    D(count) = 1/X(count)
	      ELSE
	        D(count) = 0.00000001
	      END IF
	      count = count + 1
	    END IF
	  END DO
	  DO j = 1, numspecies ! same as previous do loop
	    IF (Co(j)%solve) THEN
	      B(1,count) = Co(j)%min
	      B(2,count) = Co(j)%max
	      X(count) = Co(j)%current
	      IF (X(count) > 0.0) THEN
		    D(count) = 1/X(count)
	      ELSE
	        D(count) = 0.00000001
	      END IF
	      count = count + 1
	    END IF
	  END DO
	  CALL DMNFB(P, D, X, B, CALCF, IV, LIV, LV, V,
     $                  UIPARM, URPARM, UFPARM) ! run the optimizer
	  CALL AddNewValues(P, X) ! add the new optimized values to arrays and run 
	                          ! one more time for an optimized solution
	  CALL FinalDataTweaking(a)
	  CALL ForwardRun(path, prefix, extension, a, 0, .TRUE.)
	                      ! this param file lists the optimized parameters
	  CALL WriteParamFile(P, X, path, prefix) 
	  CALL WriteOutputFile(simtype, path, prefix)
	END IF
	! free all the arrays
	IF (ALLOCATED(a))  DEALLOCATE(a)
	IF (ALLOCATED(obspts))  DEALLOCATE(obspts)
	IF (ALLOCATED(k))  DEALLOCATE(k)
	IF (ALLOCATED(Co))  DEALLOCATE(Co)
	IF (ALLOCATED(weight))  DEALLOCATE(weight)
	IF (ALLOCATED(totaltimearray)) DEALLOCATE(totaltimearray)
	IF (ALLOCATED(obstimearray)) DEALLOCATE(obstimearray)
	IF (ALLOCATED(calcvalarray)) DEALLOCATE(calcvalarray)
	IF (ALLOCATED(obsvalarray)) DEALLOCATE(obsvalarray)
	IF (ALLOCATED(name)) DEALLOCATE(name)
	IF (ALLOCATED(yield)) DEALLOCATE(yield)
	
	! all done!
	END SUBROUTINE RunFromGMS

	SUBROUTINE WriteOutputFile (simtype, path, prefix)
	
	USE globaldata
	IMPLICIT NONE
	INTEGER simtype, prelen, templength, pathlen
	CHARACTER flname*256, prefix*40, tempstring*256, path*256
	CHARACTER string*256, currname*40, valstring*40, longstring*256
	CHARACTER shortstring*20, supername*40
	INTEGER i, j, namelen, l, index, num, count, err, longlen, m, r
	LOGICAL found
	DOUBLE PRECISION res, wres, sumres, sumwres, meanres, meanwres
	DOUBLE PRECISION sqsum, wsqsum, rms, wrms, abswres, sumabsres
	DOUBLE PRECISION sumabswres, meanabsres, meanabswres
	CHARACTER, ALLOCATABLE, DIMENSION (:) :: params*9
	INTEGER numlen

	! echo input data
	
	prelen = LEN_TRIM(prefix)
	pathlen = LEN_TRIM(path)
	flname = path(1:pathlen)//'\'//prefix(1:prelen)//'.out'
	OPEN(8,FILE=flname,FORM='FORMATTED',STATUS='unknown')
	WRITE(8,*) 'ART3D Output File'
	WRITE(8,*) ' '
	WRITE(8,*) 'Summary of Input Data'
	WRITE(8,*) '====================='
	WRITE(8,*) ' '
	IF (simtype == 0) THEN
	  WRITE (8,'(A16,T40,A18)')'Simulation Type:','Normal Forward Run'
	ELSE IF (simtype == 1) THEN
	  WRITE (8,'(A16,T40,A20)')'Simulation Type:',
     $                                            'Parameter Estimation'
	ELSE ! simtype == 2
	  WRITE (8,'(A16,T40,A14)')'Simulation Type:', 'Stochastic Run'
	END IF
	DO i = 1, numspecies
	  tempstring = name(i)
	  IF (i == 1) THEN
	    WRITE (8, '(A8,T40,A12)') 'Species:',tempstring
	  ELSE
	    WRITE (8, '(T40,A12)') tempstring
	  END IF
	END DO
	WRITE (8,'(A21,T40,A15)') 'Observation Coverage:', coveragename
	WRITE (8,'(A19,T40,ES9.3)') 'Y Source Dimension:', ysdim
	WRITE (8,'(A19,T40,ES9.3)') 'Z Source Dimension:', zsdim
	WRITE (8,'(A22,T40,ES9.3)')'Total Simulation Time:', tottime
	IF (nt < 10) THEN
	  WRITE (8,'(A28,T40,I1)') 'Number of Output Timesteps: ', nt
	ELSE IF (nt < 100) THEN
	  WRITE (8,'(A28,T40,I2)') 'Number of Output Timesteps: ', nt
	ELSE IF (nt < 1000) THEN
	  WRITE (8,'(A28,T40,I3)') 'Number of Output Timesteps: ', nt
	ELSE IF (nt < 10000) THEN
	  WRITE (8,'(A28,T40,I4)') 'Number of Output Timesteps: ', nt
	ELSE
	  WRITE (8,'(A28,T40,I5)') 'Number of Output Timesteps: ', nt
	END IF
	WRITE (8,'(A19)') 'Yield Coefficients:'
	DO i=1,numspecies
	  DO j = 1, numspecies
	    tempstring = ' '
	    string = ' '
	    IF (yield(i,j) /= 0) THEN
	      tempstring = name(j)
	      templength = LEN_TRIM(tempstring)
	      tempstring = tempstring(1:templength)//' ->'
	      templength = LEN_TRIM(tempstring)
	      tempstring = tempstring(1:templength+1)//name(i)
	      templength = LEN_TRIM(tempstring)
	      tempstring = tempstring(1:templength)//':'
	      WRITE(8,'(3X,A71,T40,ES9.3)') tempstring, yield(i,j)
	    END IF
	  END DO
	END DO
	WRITE (8,'(A11)') 'Parameters:'
	IF (simtype == 0) THEN ! normal forward run
	  WRITE (8,'(3X,A19,T40,ES9.3)') 'Retardation Factor:',
     $                                          aquiferdata(1)%start
	  WRITE (8,'(3X,A17,T40,ES9.3)') 'Seepage Velocity:',
     $                                          aquiferdata(2)%start
	  WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (x):',
     $                                          aquiferdata(3)%start
	  WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (y):',
     $                                          aquiferdata(4)%start
	  WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (z):',
     $                                          aquiferdata(5)%start
	  DO i=1, numspecies
	    tempstring = 'Decay Constant -'
	    currname = name(i)
	    namelen = LEN_TRIM(currname)
	    currname = currname(1:namelen)//':'
	    tempstring = tempstring(1:19)//currname
	    WRITE (8,'(3X,A71,T40,ES9.3)') tempstring, k(i)%start
	  END DO
	  
	  DO i=1, numspecies
	    tempstring = 'Initial Concentration -'
	    currname = name(i)
	    namelen = LEN_TRIM(currname)
	    currname = currname(1:namelen)//':'
	    tempstring = tempstring(1:26)//currname
	    WRITE (8,'(3X,A71,T40,ES9.3)') tempstring, Co(i)%start
	  END DO
      ELSE IF (simtype == 1) THEN ! parameter estimation mode
	  count = 0
	  IF (aquiferdata(1)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A19,T40,ES9.3)') 'Retardation Factor:',
     $                                          aquiferdata(1)%start
	  ELSE 
	    count = count + 1
	    WRITE (8,'(3X,A19)') 'Retardation Factor:'
	    WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(1)%start
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(1)%min
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(1)%max
	  END IF
	  IF (aquiferdata(2)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A20,T40,ES9.3)') 'Seepage Velocity:',
     $                                          aquiferdata(2)%start
	  ELSE 
	    count = count + 1
	    WRITE (8,'(3X,A17)') 'Seepage Velocity:'
	    WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(2)%start
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(2)%min
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(2)%max
	  END IF
	  IF (aquiferdata(3)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (x):',
     $                                          aquiferdata(3)%start
	  ELSE 
	    count = count + 1
	    WRITE (8,'(3X,A23)') 'Dispersivity Coeff (x):'
	    WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(3)%start
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(3)%min
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(3)%max
	  END IF
	  IF (aquiferdata(4)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (y):',
     $                                          aquiferdata(4)%start
	  ELSE 
	    count = count + 1
	    WRITE (8,'(3X,A23)') 'Dispersivity Coeff (z):'
	    WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(4)%start
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(4)%min
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(4)%max
	  END IF
	  IF (aquiferdata(5)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (z):',
     $                                          aquiferdata(5)%start
	  ELSE 
	    count = count + 1
	    WRITE (8,'(3X,A23)') 'Dispersivity Coeff (z):'
	    WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(5)%start
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(5)%min
	    WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(5)%max
	  END IF
	  DO i=1, numspecies
	    tempstring = 'Decay Constant -'
	    currname = name(i)
	    namelen = LEN_TRIM(currname)
	    currname = currname(1:namelen)//':'
	    tempstring = tempstring(1:19)//currname
	    IF (k(i)%solve == .FALSE.) THEN
	      WRITE (8,'(3X,A71,T40,ES9.3)') tempstring, k(i)%start
	    ELSE
	      count = count + 1
	      WRITE (8,'(3X,A71)') tempstring
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:', k(i)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:', k(i)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:', k(i)%max
	    END IF
	  END DO
	  
	  DO i=1, numspecies
	    tempstring = 'Initial Concentration -'
	    currname = name(i)
	    namelen = LEN_TRIM(currname)
	    currname = currname(1:namelen)//':'
	    tempstring = tempstring(1:26)//currname
	    IF (Co(i)%solve == .FALSE.) THEN
	      WRITE (8,'(3X,A71,T40,ES9.3)') tempstring, Co(i)%start
	    ELSE
	      count = count + 1
	      WRITE (8,'(3X,A71)') tempstring
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',Co(i)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',Co(i)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',Co(i)%max
	    END IF
	  END DO
	!  Write out the parameter values and error values after each iteration
	  ! Make a list of the parameters which have been marked for solving
	  IF (.NOT.ALLOCATED(params)) THEN
	    ALLOCATE(params(count), stat = err)
	  END IF
	  count = 1
	  IF (aquiferdata(1)%solve) THEN
	    params(count) = 'retard'
	    count = count + 1
	  END IF
	  IF (aquiferdata(2)%solve) THEN
	    params(count) = 'velocity'
	    count = count + 1
	  END IF
	  IF (aquiferdata(3)%solve) THEN
	    params(count) = 'alphax'
	    count = count + 1
	  END IF
	  IF (aquiferdata(4)%solve) THEN
	    params(count) = 'alphayratio'
	    count = count + 1
	  END IF
	  IF (aquiferdata(5)%solve) THEN
	    params(count) = 'alphazratio'
	    count = count + 1
	  END IF
	  DO i = 1, numspecies
	    IF (k(i)%solve) THEN
	      tempstring = 'k-'
	      currname = name(i)
	      namelen = LEN_TRIM(currname)
	      currname = currname(1:namelen)
	      params(count) = tempstring(1:2)//currname
	      count = count + 1
	    END IF
	  END DO
	  DO i = 1, numspecies
	    IF (Co(i)%solve) THEN
	      tempstring = 'Co-'
	      currname = name(i)
	      namelen = LEN_TRIM(currname)
	      currname = currname(1:namelen)
	      params(count) = tempstring(1:3)//currname
	      count = count + 1
	    END IF
	  END DO
	  count = count - 1
	! now write the iteration array to a different file that can be read into excel
	  flname = path(1:pathlen)//'\'//prefix(1:prelen)//'.itr'
	  OPEN(9,FILE=flname,FORM='FORMATTED',STATUS='unknown')
	  WRITE (9,*) 'ART3D Iteration Data'
	  WRITE (9,43) 'Iteration', (params(j),j=1,count), 'Error'
43	  FORMAT (25A12)
	  DO i = 1, maxiter
	    IF (iterationarray(1,i) == -999) EXIT
	    WRITE (9, 44) i, (iterationarray(j,i), j = 1, count+1)
44	    FORMAT (I8, 4X, 24ES12.3)
	  END DO
	  CLOSE (9);
	ELSE ! stochastic simulation
	  count = 0
	  IF (aquiferdata(1)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A19,T40,ES9.3)') 'Retardation Factor:',
     $                                          aquiferdata(1)%start
	  ELSE 
	    count = count + 1
	    IF (aquiferdata(1)%dist == 1) THEN
	      WRITE (8,'(3X,A19)') 'Retardation Factor:'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(1)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(1)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(1)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Linear'
	    ELSE
	      WRITE (8,'(3X,A19)') 'Retardation Factor:'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(1)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(1)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(1)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Normal'
	      WRITE (8,'(T20,A19,T40,ES9.3)') 'Standard Deviation:', 
     $                                          aquiferdata(1)%stddev
	    END IF
	  END IF
	  IF (aquiferdata(2)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A20,T40,ES9.3)') 'Seepage Velocity:',
     $                                          aquiferdata(2)%start
	  ELSE 
	    count = count + 1
	    IF (aquiferdata(2)%dist == 1) THEN
	      WRITE (8,'(3X,A17)') 'Seepage Velocity:'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(2)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(2)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(2)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Linear'
	    ELSE
	      WRITE (8,'(3X,A17)') 'Seepage Velocity:'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(2)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(2)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(2)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Normal'
	      WRITE (8,'(T20,A19,T40,ES9.3)') 'Standard Deviation:', 
     $                                          aquiferdata(2)%stddev
	    END IF
	  END IF
	  IF (aquiferdata(3)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (x):',
     $                                          aquiferdata(3)%start
	  ELSE 
	    count = count + 1
	    IF (aquiferdata(3)%dist == 1) THEN
	      WRITE (8,'(3X,A19)') 'Dispersivity Coeff (x):'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(3)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(3)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(3)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Linear'
	    ELSE
	      WRITE (8,'(3X,A19)') 'Dispersivity Coeff (y):'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(3)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(3)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(3)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Normal'
	      WRITE (8,'(T20,A19,T40,ES9.3)') 'Standard Deviation:', 
     $                                          aquiferdata(3)%stddev
	    END IF
	  END IF
	  IF (aquiferdata(4)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (y):',
     $                                          aquiferdata(4)%start
	  ELSE 
	    count = count + 1
	    IF (aquiferdata(4)%dist == 1) THEN
	      WRITE (8,'(3X,A19)') 'Dispersivity Coeff (y):'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(4)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(4)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(4)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Linear'
	    ELSE
	      WRITE (8,'(3X,A19)') 'Dispersivity Coeff (y):'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(4)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(4)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(4)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Normal'
	      WRITE (8,'(T20,A19,T40,ES9.3)') 'Standard Deviation:', 
     $                                          aquiferdata(4)%stddev
	    END IF
	  END IF
	  IF (aquiferdata(5)%solve == .FALSE.) THEN
          WRITE (8,'(3X,A23,T40,ES9.3)') 'Dispersivity Coeff (z):',
     $                                          aquiferdata(5)%start
	  ELSE 
	    count = count + 1
	    IF (aquiferdata(5)%dist == 1) THEN
	      WRITE (8,'(3X,A19)') 'Dispersivity Coeff (z):'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(5)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(5)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(5)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Linear'
	    ELSE
	      WRITE (8,'(3X,A19)') 'Dispersivity Coeff (z):'
	      WRITE (8,'(T20,A12, T40, ES9.3)') 'Start Value:',
     $                                          aquiferdata(5)%start
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Minimum Value:',
     $                                          aquiferdata(5)%min
	      WRITE (8,'(T20,A14, T40, ES9.3)') 'Maximum Value:',
     $                                          aquiferdata(5)%max
	      WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Normal'
	      WRITE (8,'(T20,A19,T40,ES9.3)') 'Standard Deviation:', 
     $                                          aquiferdata(5)%stddev
	    END IF
	  END IF
	  DO i=1, numspecies
	    tempstring = 'Decay Constant -'
	    currname = name(i)
	    namelen = LEN_TRIM(currname)
	    currname = currname(1:namelen)//':'
	    tempstring = tempstring(1:19)//currname
	    IF (k(i)%solve == .FALSE.) THEN
	      WRITE (8,'(3X,A71,T40,ES9.3)') tempstring, k(i)%start
	    ELSE
	      count = count + 1
	      IF (k(i)%dist == 1) THEN
	        WRITE (8,'(3X,A71)') tempstring
	        WRITE (8,'(T20,A12,T40,ES9.3)') 'Start Value:', k(i)%start
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Minimum Value:', k(i)%min
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Maximum Value:', k(i)%max
	        WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Linear'
	      ELSE
	        WRITE (8,'(3X,A71)') tempstring
	        WRITE (8,'(T20,A12,T40,ES9.3)') 'Start Value:', k(i)%start
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Minimum Value:', k(i)%min
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Maximum Value:', k(i)%max
	        WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Normal'
	        WRITE (8,'(T20,A19,T40,ES9.3)') 'Standard Deviation:',
     $                                            k(i)%stddev
	      END IF
	    END IF
	  END DO
	  
	  DO i=1, numspecies
	    tempstring = 'Initial Concentration -'
	    currname = name(i)
	    namelen = LEN_TRIM(currname)
	    currname = currname(1:namelen)//':'
	    tempstring = tempstring(1:26)//currname
	    IF (Co(i)%solve == .FALSE.) THEN
	      WRITE (8,'(3X,A71,T40,ES9.3)') tempstring, Co(i)%start
	    ELSE
	      count = count + 1
	      IF (Co(i)%dist == 1) THEN
	        WRITE (8,'(3X,A71)') tempstring
	        WRITE (8,'(T20,A12,T40,ES9.3)') 'Start Value:',Co(i)%start
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Minimum Value:',Co(i)%min
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Maximum Value:',Co(i)%max
	        WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Linear'
	      ELSE
	        WRITE (8,'(3X,A71)') tempstring
	        WRITE (8,'(T20,A12,T40,ES9.3)') 'Start Value:',Co(i)%start
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Minimum Value:',Co(i)%min
	        WRITE (8,'(T20,A14,T40,ES9.3)') 'Maximum Value:',Co(i)%max
	        WRITE (8,'(T20,A13,T40,A6)') 'Distribution:','Normal'
	        WRITE (8,'(T20,A19,T40,ES9.3)') 'Standard Deviation:',
     $                                            Co(i)%stddev
	      END IF
	    END IF
	  END DO
	  WRITE (8,*) ' '
	  WRITE (8,*) ' '
	  WRITE (8,*) 'Output Files'
	  WRITE (8,*) '============'
	  WRITE (8,*) 'List of Dataset Superfiles:'
	  tempstring = path(1:pathlen)//'\'//
     $            prefix(1:prelen)//'.sto'
	  templength = LEN_TRIM(tempstring)
	  WRITE (8,*) '          ', tempstring(1:templength)
	  WRITE (8,*) 'Iteration File (list of random values):'
	  tempstring = path(1:pathlen)//'\'//
     $            prefix(1:prelen)//'.itr'
	  templength = LEN_TRIM(tempstring)
	  WRITE (8,*) '          ', tempstring(1:templength)
	END IF
	IF (simtype /= 2) THEN  ! not written in stochastic output files
	  WRITE (8,*) ' '
	  WRITE (8,*) ' '
	  WRITE (8,*) 'Output Files'
	  WRITE (8,*) '============'
	  tempstring = 'Dataset Superfile:'
	  tempstring = tempstring(1:19)//path(1:pathlen)//'\'//
     $                prefix(1:prelen)//'.dss'
	  templength = LEN_TRIM(tempstring)
	  WRITE (8,*) tempstring(1:templength)
	  WRITE (8,*) 'Dataset Files:'
	  DO i=1,numspecies
	    currname = name(i)
	    namelen = LEN_TRIM(currname)
	    tempstring = path(1:pathlen)//'\'//prefix(1:prelen)//
     $                 '_'//currname(1:namelen)//'.dat'
	    templength = LEN_TRIM(tempstring)
	    tempstring = '  '//tempstring
	    WRITE (8,*) tempstring(1:templength+2)
	  END DO
	END IF
	IF (simtype == 1 .OR. simtype == 2) THEN ! parameter estimation or stoch
	  tempstring = 'Iteration Data File:'
	  tempstring = tempstring(1:21)//path(1:pathlen)//'\'//
     $                 prefix(1:prelen)//'.itr'
	END IF
	IF (numobs > 0 ) THEN  
	     ! write out information on observation points and error
	  tempstring = 'Observation Point Data File:'
	  tempstring = tempstring(1:29)//path(1:pathlen)//'\'//
     $                   prefix(1:prelen)//'.ats'
	  templength = LEN_TRIM(tempstring)
	  
	  IF (simtype /= 2) THEN  ! not written in stoch output files
	    ! this part of the file lists all the obs pts at each timestep (obs and grid)
	    ! and their calculated and observed(where known) values.  It also calculates
	    ! a residual and weighted residual (based on weight matrix) for each known obs
	    ! value.  At the bottom, the residuals and weighted residuals are summarized with
	    ! the sum, mean, absolute mean, and root mean square.
	    WRITE (8,*) tempstring(1:templength)
	    WRITE (8,*) ' '
	    WRITE (8,*) ' '
	    WRITE (8,*) 'Observation Point Data'
	    WRITE (8,*) '======================'
	    tempstring = '  Point     Time     Species  Comp Val   '
	    tempstring = tempstring(1:41)//'Obs Val   Residual     '
	    tempstring = tempstring(1:62)//'Wtd Res '
	    WRITE (8,*) tempstring(1:71)
	    tempstring = '--------- --------- --------- ---------'
	    tempstring = tempstring(1:39)//' --------- ----------'
	    tempstring = tempstring(1:60)//' ----------'
	    WRITE (8,*) tempstring(1:71)
	    sumres = 0
	    sumabsres = 0
	    sumwres = 0
	    sumabswres = 0
	    sqsum = 0
	    wsqsum = 0
	    num = 0
	    DO l = 1, numobs
	      DO j = 1, totalnumts
	        DO i = 1, numspecies
	          tempstring = obspts(l)%name
	          WRITE(valstring, '(ES9.3)') totaltimearray(j)
	          tempstring = tempstring(1:49)//' '//valstring !emrl added 40
	          tempstring = tempstring(1:59)//' '//name(i)   !emrl added 40
	          WRITE(valstring, '(ES9.3)') calcvalarray(l,j,i)
	          tempstring = tempstring(1:69)//' '//valstring !emrl added 40
                CALL FindInArray (obstimearray, numobsts, 
     $                    totaltimearray(j), index, found)
	          IF (found) THEN
	            IF (obsvalarray(l, index, i) /= -999) THEN
	            WRITE(valstring, '(ES9.3)') obsvalarray(l,index,i)
	              tempstring = tempstring(1:79)//' '//valstring !emrl added 40
	              res = calcvalarray(l,j,i)-obsvalarray(l,index,i)
	              num = num + 1
	              sumres = sumres + res
	              sumabsres = sumabsres + ABS(res)
	              sqsum = sqsum + (res*res)
	              WRITE(valstring, '(ES10.3)') res
	              tempstring = tempstring(1:89)//' '//valstring !emrl added 40
	              wres = res * weight(i,l)
	              sumwres = sumwres + wres
	              abswres = ABS(res) * weight(i,l)
	              sumabswres = sumabswres + abswres
	              wsqsum = wsqsum + (res*weight(i,l)*res*weight(i,l))
	              WRITE(valstring, '(ES10.3)') wres
	              tempstring = tempstring(1:100)//' '//valstring !emrl added40
	            ELSE
	              tempstring = tempstring(1:79)//'                 '!emrl added 40
	              tempstring = tempstring(1:94)//'                 '!emrl added 40
	              tempstring = tempstring(1:105)//'                 '!emrl added 40
	            END IF
	          ELSE
	            tempstring = tempstring(1:79)//'                 '!emrl added 40
	            tempstring = tempstring(1:94)//'                 '!emrl added 40
	            tempstring = tempstring(1:105)//'                 '!emrl added 40
	          END IF
	          WRITE (8,*) tempstring(1:111)  !emrl added 40     
	        END DO
	      END DO
	    END DO
	    tempstring = '========================================'
	    tempstring = tempstring(1:40)//'===================='
	    tempstring = tempstring(1:60)//'=================='
	! here come the summarization lines
	    IF (num > 0) THEN
	      WRITE (8,*) tempstring(1:71)
	      tempstring = 'Sum:                                      '
	      tempstring = tempstring(1:40)//'               '
	      WRITE(valstring, '(ES10.3)') sumres
	      tempstring = tempstring(1:49)//' '//valstring
	      WRITE(valstring, '(ES10.3)') sumwres
	      tempstring = tempstring(1:60)//' '//valstring
	      WRITE (8,*) tempstring(1:71)
	      tempstring = 'Mean:                                     '
	      tempstring = tempstring(1:40)//'               '
	      meanres = sumres/num
	      meanwres = sumwres/num
	      WRITE (valstring, '(ES10.3)') meanres
	      tempstring = tempstring(1:49)//' '//valstring
	      WRITE (valstring, '(ES10.3)') meanwres
	      tempstring = tempstring(1:60)//' '//valstring
	      WRITE (8,*) tempstring(1:71)
	      tempstring = 'Mean Absolute:                               '
	      tempstring = tempstring(1:34)//'                     '
	      meanabsres = sumabsres/num
	      meanabswres = sumabswres/num
	      WRITE (valstring, '(ES10.3)') meanabsres
	      tempstring = tempstring(1:49)//' '//valstring
	      WRITE (valstring, '(ES10.3)') meanabswres
	      tempstring = tempstring(1:60)//' '//valstring
	      WRITE (8,*) tempstring(1:71)
	      tempstring = 'Root mean square:                         '
	      tempstring = tempstring(1:40)//'               '
	      rms = sqsum/num
	      rms = SQRT(rms)
	      WRITE (valstring, '(ES10.3)') rms
	      tempstring = tempstring(1:49)//' '//valstring
	      wrms = wsqsum/num
	      wrms = SQRT(wrms)
	      WRITE (valstring, '(ES10.3)') wrms
	      tempstring = tempstring(1:60)//' '//valstring
	      WRITE (8,*) tempstring(1:71)
	    END IF
	  END IF
	END IF
	IF (simtype == 2) THEN ! only for stochastic runs 
	                       ! - lists dataset superfiles for each run
	  flname = path(1:pathlen)//'\'//prefix(1:prelen)//'.sto'
	  OPEN(9,FILE=flname,FORM='FORMATTED',STATUS='unknown')
	  DO i=1, stochruns
	    IF (i < 10) THEN
	      WRITE(string,'(I1)') i
	      numlen = 1
	    ELSE IF (i < 100) THEN
	      WRITE(string,'(I2)') i
	      numlen = 2
	    ELSE IF (i < 1000) THEN
	      WRITE(string,'(I3)') i
	      numlen = 3
	    ELSE IF (i < 10000) THEN
	      WRITE(string,'(I4)') i
	      numlen = 4
	    ELSE IF (i < 100000) THEN
	      WRITE(string,'(I5)') i
	      numlen = 5
	    END IF
	    supername = '"'//prefix(1:prelen)//string(1:numlen)//
     $                              '.dss'//'"'
	    WRITE (9,*) "STORUN ", supername
	  END DO
	END IF
	END SUBROUTINE WriteOutputFile

	SUBROUTINE SortArray (oldarray, size)
	   ! sorts values in the array from small to big
	INTEGER size
	DOUBLE PRECISION oldarray(size), newarray(size)
	INTEGER i, j
	DOUBLE PRECISION min, max

	min = oldarray(1)
	DO j = 1, size
	  IF (oldarray(j) < min) THEN
	    min = oldarray(j)
	  END IF
	END DO
	max = oldarray(1)
	DO j = 1, size
	  IF (oldarray(j) > max) THEN
	    max = oldarray(j)
	  END IF
	END DO
	DO i = 1, size
	  DO j = 1, size
	    IF (oldarray(j) <= min.AND.oldarray(j).NE.0) THEN
	      min = oldarray(j)
	    END IF
	  END DO
	  DO j = 1, size
	    IF (oldarray(j) == min) THEN
	      oldarray(j) = 0
	      newarray(i) = min
	    END IF
	  END DO
	  min = max
	END DO
	DO j = 1, size
	  oldarray(j) = newarray(j)
	END DO

	END SUBROUTINE

	FUNCTION SearchArray (array, size, val)

	  ! searches to see if a certain value is already in the array
	IMPLICIT NONE
	INTEGER i, size
	DOUBLE PRECISION array(size), val
	LOGICAL SearchArray

	DO i = 1, size
	  IF (array(i) == val) THEN
	    SearchArray = .TRUE.
	    RETURN
	  END IF
	END DO
	SearchArray = .FALSE.
	RETURN

	END FUNCTION SearchArray

	SUBROUTINE FindInArray (array, size, val, index, found)

	 ! same as SearchArray
	IMPLICIT NONE
	INTEGER, INTENT (in) :: size
	INTEGER, INTENT (out) :: index
	DOUBLE PRECISION, INTENT (in) :: array(size)
	DOUBLE PRECISION, INTENT (in) :: val
	LOGICAL, INTENT (out) :: found
	INTEGER i

	found = .FALSE.
	DO i = 1, size
	  IF (array(i) == val) THEN
	    found = .TRUE.
	    index = i
	    RETURN
	  END IF
	END DO

	END SUBROUTINE

	SUBROUTINE WriteParamFile(P, X, path, prefix)

	! this file (*.par) lists all the optimized parameters at the end of an optimization
	! run.  This is used to read them back into the parameters dialog on selection of the
	! "Import Parameters" button

	CHARACTER, INTENT(IN) :: path*256
	CHARACTER, INTENT(IN) :: prefix*40
	CHARACTER :: flname*256
	INTEGER P, i, pathlen, prelen
	DOUBLE PRECISION, DIMENSION(P) :: X

	pathlen = LEN_TRIM(path)
	prelen = LEN_TRIM(prefix)
	flname = path(1:pathlen)//'\'//prefix(1:prelen)//'.par'
	OPEN(UNIT=37,FILE=flname,FORM='formatted',
     $         STATUS='Unknown', IOSTAT=err)
	IF (err.NE.0) THEN
	  CALL ErrorMessageAndStop(10, '')
	END IF
	WRITE (37,*) 'PARAMETERS'
	DO i=1, P
	  WRITE (37,*) X(i)
	END DO
	WRITE(37,*) 'END'
	CLOSE(37)

	END SUBROUTINE

	SUBROUTINE UFPARM()

	! No clue what this is supposed to do!!  But it's necessary for the PORT library
	! the optimization routine seems to work fine with this function left empty

	END SUBROUTINE UFPARM

	SUBROUTINE AddNewValues(P, X)

	! add the new values from the last PORT library run to the %current part of the
	! parameter structures so that ART3D can be run again and the objective function
	! can be calcluated

	USE globaldata
	IMPLICIT NONE
	INTEGER P, count, i
	DOUBLE PRECISION, DIMENSION(P) :: X

	count = 1
	DO i = 1, 3
	  IF (aquiferdata(i)%solve) THEN
	    aquiferdata(i)%current = X(count)
	    count = count + 1
	  ELSE 
	    aquiferdata(i)%current = aquiferdata(i)%start
	  END IF
	END DO
	DO i = 6, 7
	  IF (aquiferdata(i)%solve) THEN
	    aquiferdata(i)%current = X(count)
	    count = count + 1
	  ELSE 
	    aquiferdata(i)%current = aquiferdata(i)%start
	  END IF
	END DO
	DO i = 1, numspecies
	  IF (k(i)%solve) THEN
	    k(i)%current = X(count)
	    count = count + 1
	  ELSE
	    k(i)%current = k(i)%start
	  END IF
	END DO
	DO i = 1, numspecies
	  IF (Co(i)%solve) THEN
	    Co(i)%current = X(count)
	    count = count + 1
	  ELSE
	    Co(i)%current = Co(i)%start
	  END IF
	END DO

	END SUBROUTINE

	SUBROUTINE CALCF(P, X, NF, FX, UIPARM, URPARM, UFPARM)
	! this subroutine calculates the objective function by running ART3D, and computing the error
	! at the observation points

	USE globaldata
	IMPLICIT NONE
	CHARACTER :: path*256
	CHARACTER :: prefix*40
	CHARACTER :: extension*3
	DOUBLE PRECISION, DIMENSION(numspecies,numspecies) :: a
	INTEGER P, NF
	DOUBLE PRECISION FX
      DOUBLE PRECISION, DIMENSION(P) :: D, X
	DOUBLE PRECISION, DIMENSION(2,P) :: B
	INTEGER, DIMENSION(1) :: UIPARM
	DOUBLE PRECISION, DIMENSION(1) :: URPARM
	DOUBLE PRECISION insideerror, outsideerror, diff
	INTEGER i, j, count

	EXTERNAL UFPARM
	
	
	CALL AddNewValues(P, X)  ! add the latest values from the PORT library to 
	                         ! the appropriate arrays and structures
	CALL FinalDataTweaking(a)  ! now run ART3D without solving for the grid
	CALL ForwardRun(path, prefix, extension, a, 0, .FALSE.)

	! the following lines calculate the total weighted error across all obs points
	insideerror = 0
	outsideerror = 0
	DO i = 1, numspecies
	  DO j = 1, numobs
	    DO count = 1, numobsts
	      IF (obsvalarray(j,count,i) /= -999) THEN
	        diff = calcvalarray(j,count,i) - obsvalarray(j,count,i)
	      ELSE
	        diff = 0
	      END IF
	        insideerror = insideerror + weight(i,j) *  ABS(diff)
	    END DO
	  END DO
	  outsideerror = outsideerror + insideerror
	  insideerror = 0
	END DO
	FX = outsideerror  ! send the error back to the PORT library
	CALL AddIterationToArray(P,X,FX,NF)
	
	END SUBROUTINE CALCF

	SUBROUTINE AddIterationToArray(size, params, error, index)

	! this array is used to write out the *.itr file

	USE globaldata
	IMPLICIT NONE

	INTEGER, INTENT(IN) :: size, index
	DOUBLE PRECISION, INTENT(IN) :: params(size)
	DOUBLE PRECISION, INTENT(IN) :: error
	INTEGER i, j, err
	
	IF (index <= maxiter) THEN
	  IF (.NOT.ALLOCATED(iterationarray))	THEN
	    ALLOCATE (iterationarray(size+1, maxiter), stat = err)
	    DO i = 1, size+1
	      DO j = 1, maxiter
	        iterationarray(i,j) = -999
	      END DO
	    END DO
	  END IF
	  DO j = 1, size
	    iterationarray(j,index) = params(j)
	  END DO
	  iterationarray(size+1,index) = error
	END IF

	END SUBROUTINE

	SUBROUTINE GetCurrentData()
	USE globaldata
	IMPLICIT NONE
	INTEGER i

	! this function copies the start values into the %current spot to get ready to run ART3D

	DO i=1,7
	  aquiferdata(i)%current = aquiferdata(i)%start
	END DO
	DO i = 1, numspecies
	  k(i)%current = k(i)%start
	  Co(i)%current = Co(i)%start
	END DO

	END SUBROUTINE GetCurrentData

	SUBROUTINE PrintStochasticData(numrun, numparams)

	! this prints data on each stochastic run to the screen and to the *.itr file
	USE globaldata
	IMPLICIT NONE
	INTEGER, INTENT(IN) :: numrun
	INTEGER i, len, numparams, j
	CHARACTER currname*20
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: vals

	WRITE(*,*) ''
	WRITE(*,'(A22, I6)') 'Stochastic run number ', numrun
	WRITE(*,*) 'Retard = ',aquiferdata(1)%current
	WRITE(*,*) 'Velocity = ', aquiferdata(2)%current
	WRITE(*,*) 'Alpha x = ', aquiferdata(3)%current
	WRITE(*,*) 'Alpha y / Alpha x = ', aquiferdata(6)%current
	WRITE(*,*) 'Alpha z / Alpha x = ', aquiferdata(7)%current
	DO i = 1, numspecies
	  currname = name(i)
	  len = LEN_TRIM(currname)
	  WRITE (*,*) 'k_', currname(1:len), ' = ', k(i)%current
	END DO
	DO i = 1, numspecies
	  currname = name(i)
	  len = LEN_TRIM(currname)
	  WRITE(*,*) 'Co_', currname(1:len), ' = ', Co(i)%current
	END DO

	ALLOCATE (vals(numparams))
	j = 1
	DO i = 1,3 
	  IF (aquiferdata(i)%solve) THEN
	    vals(j) = aquiferdata(i)%current
	    j = j + 1
	  END IF
	END DO
	DO i = 6,7 
	  IF (aquiferdata(i)%solve) THEN
	    vals(j) = aquiferdata(i)%current
	    j = j + 1
	  END IF
	END DO
	DO i = 1, numspecies
	  IF (k(i)%solve) THEN
	    vals(j) = k(i)%current
	    j = j + 1
	  END IF
	END DO
	DO i = 1, numspecies
	  IF (Co(i)%solve) THEN
	    vals(j) = Co(i)%current
	    j = j + 1
	  END IF
	END DO
	WRITE (17,36) numrun, (vals(j), j = 1, numparams)
36	FORMAT (I4, 46ES12.3)


	END SUBROUTINE PrintStochasticData

	SUBROUTINE GetRandomData()

	! this routine gets the random data (monte carlo approach)
	USE globaldata
	IMPLICIT NONE
	DOUBLE PRECISION rand, r, v1, v2, x, fac
	INTEGER i
	
	CALL RANDOM_SEED()
	DO i=1,3
	  IF (aquiferdata(i)%solve) THEN
	    CALL RANDOM_NUMBER(rand)
	    IF (aquiferdata(i)%dist == 1) THEN ! linear distribution
	      aquiferdata(i)%current = ((aquiferdata(i)%max - 
     $	       aquiferdata(i)%min)*rand) + aquiferdata(i)%min
	    ELSE IF (aquiferdata(i)%dist == 0) THEN ! normal distribution
	      x = aquiferdata(i)%min - 1
	      DO WHILE (x < aquiferdata(i)%min.OR.
     $	               x > aquiferdata(i)%max)
	        r = 1
	        DO WHILE (r >= 1)
	          CALL RANDOM_NUMBER(rand)
	          v1 = 2*rand - 1
	          CALL RANDOM_NUMBER(rand)
	          v2 = 2*rand - 1
	          r = (v1 ** 2) + (v2 ** 2)
	        END DO
	        fac = v2 * SQRT(-2 * LOG10(r)/r)
	        x = fac * aquiferdata(i)%stddev + 
     $                                 aquiferdata(i)%start
	      END DO
	      aquiferdata(i)%current = x
	    END IF
	  ELSE 
	    aquiferdata(i)%current = aquiferdata(i)%start
	  END IF
	END DO
		DO i=6,7
	  IF (aquiferdata(i)%solve) THEN
	    CALL RANDOM_NUMBER(rand)
	    IF (aquiferdata(i)%dist == 1) THEN ! linear distribution
	      aquiferdata(i)%current = ((aquiferdata(i)%max - 
     $	       aquiferdata(i)%min)*rand) + aquiferdata(i)%min
	    ELSE IF (aquiferdata(i)%dist == 0) THEN ! normal distribution
	      x = aquiferdata(i)%min - 1
	      DO WHILE (x < aquiferdata(i)%min.OR.
     $	               x > aquiferdata(i)%max)
	        r = 1
	        DO WHILE (r >= 1)
	          CALL RANDOM_NUMBER(rand)
	          v1 = 2*rand - 1
	          CALL RANDOM_NUMBER(rand)
	          v2 = 2*rand - 1
	          r = (v1 ** 2) + (v2 ** 2)
	        END DO
	        fac = v2 * SQRT(-2 * LOG10(r)/r)
	        x = fac * aquiferdata(i)%stddev + 
     $                                 aquiferdata(i)%start
	      END DO
	      aquiferdata(i)%current = x
	    END IF
	  ELSE 
	    aquiferdata(i)%current = aquiferdata(i)%start
	  END IF
	END DO
	aquiferdata(4)%current = aquiferdata(3)%current * 
     $                                      aquiferdata(6)%current
	aquiferdata(5)%current = aquiferdata(3)%current * 
     $                                      aquiferdata(7)%current
	DO i=1,numspecies
	  IF (k(i)%solve) THEN 
	    CALL RANDOM_NUMBER(rand)
	    IF (k(i)%dist == 1) THEN ! linear distribution
	      k(i)%current = ((k(i)%max - k(i)%min)*rand) + k(i)%min
	    ELSE IF (k(i)%dist == 0) THEN ! normal distribution
	      x = k(i)%min - 1
	      DO WHILE (x < k(i)%min.OR.x > k(i)%max)
	        r = 1
	        DO WHILE (r >= 1)
	          CALL RANDOM_NUMBER(rand)
	          v1 = 2*rand - 1
	          CALL RANDOM_NUMBER(rand)
	          v2 = 2*rand - 1
	          r = (v1 ** 2) + (v2 ** 2)
	          CALL RANDOM_NUMBER(rand)
	        END DO
	        fac = v2 * SQRT(-2 * LOG10(r)/r)
	        x = fac * k(i)%stddev + k(i)%start
	      END DO
	      k(i)%current = x
	    END IF
	  ELSE 
	    k(i)%current = k(i)%start
	  END IF
	  IF (Co(i)%solve) THEN
	    CALL RANDOM_NUMBER(rand)
	    IF (Co(i)%dist == 1) THEN ! linear distribution
	      Co(i)%current = ((Co(i)%max - Co(i)%min)*rand) + Co(i)%min
	    ELSE IF (Co(i)%dist == 0) THEN ! normal distribution
	      x = Co(i)%min - 1
	      DO WHILE (x < Co(i)%min.OR.x > Co(i)%max)
	        r = 1
	        DO WHILE (r >= 1)
	          CALL RANDOM_NUMBER(rand)
	          v1 = 2*rand - 1
	          CALL RANDOM_NUMBER(rand)
	          v2 = 2*rand - 1
	          r = (v1 ** 2) + (v2 ** 2)
	        END DO
	        fac = v2 * SQRT(-2 * LOG10(r)/r)
	        x = fac * Co(i)%stddev + Co(i)%start
	      END DO
	      Co(i)%current = x
	    END IF
	  ELSE 
	    Co(i)%current = Co(i)%start
	  END IF
	END DO

	END SUBROUTINE

	SUBROUTINE ForwardRun(path, prefix, extension, a, runnum, 
     $                                                        solvegrid)

	! run ART3D!!!

	USE globaldata
	IMPLICIT NONE
	CHARACTER, INTENT(IN) :: path*256
	CHARACTER, INTENT(IN) :: prefix*40
	CHARACTER, INTENT(IN) :: extension*3
	INTEGER, INTENT(IN) :: runnum
	INTEGER IVERSION, N7, JSFLT, JSFLG, ISTAT, IOBTY, ISFLT, ISFLG
	INTEGER ISCL, IVEC, INODE, IELEM, ITS, INAME, ierr, j, i, l, info
	INTEGER ic, ixyz, pathlen, prelen, namelen, err, it
	CHARACTER datasetname*40, flname*256, currname*256, tsfilename*256
	DOUBLE PRECISION evr(numspecies), s(numspecies, numspecies)
	DOUBLE PRECISION evi(numspecies),vecs(numspecies, numspecies)
	DOUBLE PRECISION scr1(numspecies), scr2(numspecies), sum
	DOUBLE PRECISION work(numspecies), sinv(numspecies, numspecies)
	INTEGER ipiv(numspecies), sp, ik, iz, iy, ix, temp
	DOUBLE PRECISION bo(numspecies)
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION (:,:,:) :: b2
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION (:,:,:,:) :: c
	DOUBLE PRECISION, ALLOCATABLE, DIMENSION (:,:,:,:) :: b
	DOUBLE PRECISION dt, time,x,y,z
	DOUBLE PRECISION a(numspecies,numspecies)
	INTEGER ts, formatnum,m,kount, length
	CHARACTER outputstring*220, string*11, supername*256, tempstr*256
	LOGICAL solvegrid
	INTEGER numlen, filelen

	ALLOCATE (c(grid%nx,grid%ny,grid%nz,numspecies))
	ALLOCATE (b(grid%nx,grid%ny,grid%nz,numspecies))
	ALLOCATE (b2(numobs, totalnumts, numspecies))

c	******Open and write headers for xyz-data files***********
	ixyz = 100
	DATA IVERSION /3000/
	DATA N7 /7/
      DATA JSFLT,JSFLG,ISTAT /8,4,0/
	DATA IOBTY,ISFLT,ISFLG,ISCL,IVEC,INODE,IELEM,INAME,ITS
     %     /100,110,120,130,140,170,180,190,200/
c     *********** Open and write header for *.dss file *********
	
c	WRITE (*,*) "Writing *.dss file"
	IF (solvegrid) THEN
	  pathlen = LEN_TRIM(path)
	  prelen = LEN_TRIM(prefix)
	  IF (runnum > 0) THEN !stochastic
	    IF (runnum < 10) THEN
	      WRITE(string,'(I1)') runnum
	      numlen = 1
	    ELSE IF (runnum < 100) THEN
	      WRITE(string,'(I2)') runnum
	      numlen = 2
	    ELSE IF (runnum < 1000) THEN
	      WRITE(string,'(I3)') runnum
	      numlen = 3
	    ELSE IF (runnum < 10000) THEN
	      WRITE(string,'(I4)') runnum
	      numlen = 4
	    ELSE IF (runnum < 100000) THEN
	      WRITE(string,'(I5)') runnum
	      numlen = 5
	    END IF
	! writing out dataset super file
	    supername = path(1:pathlen)//'\'//prefix(1:prelen)//
     $                                   string(1:numlen)//'.dss'
	  ELSE
	    supername = path(1:pathlen)//'\'//prefix(1:prelen)//'.dss'
	  END IF
	  OPEN(UNIT = 73, FILE = supername, FORM = 'formatted',
     $       STATUS='Unknown', IOSTAT=err)
	  IF (err/=0) THEN
	    CALL ErrorMessageAndStop(9,'')
	  END IF
	  WRITE (73, '(A5)') 'SUPER'
        DO ic = 1, numspecies
	    currname = name(ic)
	    namelen = LEN_TRIM(currname)
	    datasetname = currname(1:namelen)
	    IF (runnum > 0) THEN
	      currname = currname(1:namelen)//string
	      namelen = LEN_TRIM(currname)
	    END IF
	    flname = prefix(1:prelen)//'_'//
     $              currname(1:namelen)//'.dat'
	    filelen = LEN_TRIM(flname)
	    tempstr = 'DATA "'//flname(1:filelen)//'"'
	    WRITE(73, '(A256)') tempstr
c	    WRITE(73, '(A5,A1,A256,A1)') 'DATA ', '"', 
c     $                              flname(1:filelen), '"'
	    flname = path(1:pathlen)//'\'//flname
	    OPEN(UNIT=ixyz+ic,FILE=flname,FORM='unformatted',
     $         STATUS='Unknown', IOSTAT=err)
		IF (err /= 0) THEN
	      CALL ErrorMessageAndStop(8, currname)
	    END IF
	    
	    WRITE(ixyz+ic) IVERSION,IOBTY,N7,ISFLT,JSFLT,ISFLG,JSFLG
	    WRITE(ixyz+ic) ISCL
	    WRITE(ixyz+ic) INODE, grid%nx*grid%ny*grid%nz
	    WRITE(ixyz+ic) IELEM, (grid%nx-1)*(grid%ny-1)*(grid%nz-1)
	    WRITE(ixyz+ic) INAME, datasetname
49	FORMAT (I4, 1X, I3, 1X, I1, 1X, I3, 1X, I1, 1X, I3, 1X, I1)
        ENDDO
	  
	  IF (runnum > 0) THEN ! stochastic
	    flname = path(1:pathlen)//'\'//prefix(1:prelen)//
     $	                          string(1:numlen)//'.ctr'
	  ELSE
	    flname = path(1:pathlen)//'\'//prefix(1:prelen)//'.ctr'
	  END IF
	  OPEN(UNIT=117,FILE=flname,FORM='formatted',
     $         STATUS='Unknown', IOSTAT=err)
	  IF (err /= 0) THEN
	    CALL ErrorMessageAndStop(8, currname)
	  END IF
	END IF
c     ********** Open and write header for *.ats file **********
	  ! this file lists the concentration values for each specie at each obs point and each timestep
	IF (numobs > 0.AND.solvegrid) THEN
	  prelen = LEN_TRIM(prefix)
 	  pathlen = LEN_TRIM(path)
	  IF (runnum > 0) THEN
	    tsfilename = path(1:pathlen)//'\'//prefix(1:prelen)//
     $                string(1:numlen)//'.ats'
	  ELSE
          tsfilename = path(1:pathlen)//'\'//prefix(1:prelen)//'.ats'
	  END IF
	  OPEN(UNIT=200,FILE=tsfilename,FORM='formatted',
     $     STATUS='Unknown',IOSTAT=err)
	  IF (err/=0) THEN
	    CALL ErrorMessageAndStop(9,'')
	  END IF
	  WRITE (200, '(A10, A36)') 'Coverage: ', coveragename
        WRITE (200,57) 'PointName', 'Time', 
     $                            (name(i), i=1, numspecies)
57	  FORMAT (A9, 10X, A50, 17X, A4, 15X, 23A23) !emrl changed A8 to A50 so
	END IF                                       !Obs pts names can be longer
	
	CALL EIGEN(1, numspecies, numspecies, a, evr, evi, vecs, scr1, 
     $                 scr2, ierr)	

      DO j=1, numspecies
        DO i = 1, numspecies
          s(i,j) = vecs(i,j)
          a(i,j) = vecs(i,j)
        END DO
      END DO

	CALL DGETRF(numspecies, numspecies, a, numspecies, ipiv, info )

	CALL DGETRI(numspecies, a, numspecies, ipiv, work, numspecies, 
     $                                          info )

	DO j=1, numspecies
	  DO i = 1, numspecies
	      sinv(i,j) = a(i,j)       !   s-1 matrix
	  END DO
	END DO

	DO i = 1, numspecies
	  DO j = 1, numspecies
	    sum = 0.0
	    DO l = 1, numspecies
	      sum = sum +s(i,l)*sinv(l,j)     !(s)*(s-1)=1
		END DO
	    a(i,j) = sum
	  END DO
	END DO
13	  FORMAT (9f8.4)

	DO i=1,numspecies
	  sum=0.0
	  DO j=1,numspecies
	    sum=sum+abs(a(i,j))
	  END DO
	  IF (sum>1+numspecies*0.001) THEN
		WRITE(*,*)" "
	    WRITE(*,*)" There is a problem in Row Number:",i
		WRITE (*,*)" Look through the input data"
		WRITE(*,*)" "
	  END IF
	END DO
	 
c      Initial condition
	IF (solvegrid) THEN
        DO l=1,grid%nz
	    DO j=1, grid%ny
            DO i = 1, grid%nx
	        DO sp=1,numspecies
	          c(i,j,l,sp) = 0.0
	        END DO
	      END DO
          END DO
	  END DO
	END IF

c      Transform boundary condition
      DO i = 1, numspecies
        sum = 0.0
        DO l = 1, numspecies
          sum = sum +sinv(i,l)*Co(l)%current
        END DO
        bo(i) = sum
      END DO
      


c      Solve the problem in the "b" domain (DOMENICO SOLUTION)
	IF (solvegrid) THEN
	  dt = tottime/nt
        DO it=1,nt !begin time loop.
	    WRITE (*,*) "Solving timestep #", it
	    DO i=1, numspecies
            CALL Domenico(numspecies,grid%nx,grid%ny,grid%nz,it,grid%dx,
     $              grid%dy,grid%dz,dt,xsloc,ysloc,xsdim,ysdim,zsdim,
     $              aquiferdata(2)%current,aquiferdata(3)%current,
     $              aquiferdata(4)%current,aquiferdata(5)%current,
     $              bo(i),-evr(i),b(1,1,1,i))
	    END DO

c      Transfer the solution back to the "c" domain
       
	    DO ik=1,grid%nz
	      DO j=1,grid%ny
	        DO i=1,grid%nx
	          DO ic=1,numspecies
	            sum=0
	            DO l=1,numspecies
	              sum=sum+s(ic,l)*b(i,j,ik,l)
	            END DO
	            c(i,j,(grid%nz+1-ik),ic) = sum !(grid%nz+1-ik),ic)=sum
	          END DO
	        END DO
	      END DO
	    END DO

c*****Write x-y-z data for all species*************

          DO ic = 1, numspecies
	      time = it*dt
	      WRITE(ixyz+ic) ITS,ISTAT,time
	      WRITE(ixyz+ic) (((c(ix,iy,iz,ic),ix=1,grid%nx),
     $	                     iy=1,grid%ny),iz=1,grid%nz)
          END DO
	    WRITE (117, '(ES10.3)') time
	    DO ix = 1, grid%nx
	      WRITE (117, 118) ix*grid%dx, 
     $          (c(ix,(((grid%ny-1)/2)+1),grid%nz, ic), ic=1,numspecies)
118   FORMAT(20ES11.3)
	    END DO
	  END DO ! end of time loop

        DO ic = 1, numspecies
	    WRITE (ixyz+ic) 210
	    CLOSE (ixyz+ic)
	  END DO
	  CLOSE (73)
	  CLOSE (117)
	END IF

	IF (solvegrid) THEN
	  WRITE (*,*) 'Solving observation points.'
	END IF
	DO ts = 1, totalnumts
	  DO kount = 1, numobs
	    x = obspts(kount)%x/grid%dx
	    y = obspts(kount)%y/grid%dy
	    z = (((grid%nz-1)*grid%dz) - obspts(kount)%z)/grid%dz
	    dt = tottime/nt
	    DO i=1,numspecies 
	      CALL ObservationDomenico(x,y,z,totaltimearray(ts),
     $              bo(i),-evr(i),b2(kount,ts,i))
	    END DO
	    DO ic=1,numspecies
	      sum=0
	      DO l=1,numspecies
	        sum=sum+s(ic,l)*b2(kount,ts,l)
		  END DO
	      calcvalarray(kount,ts,ic)=sum
	    END DO
	  END DO
	END DO
	DO i = 1, numobs
	  DO j = 1, totalnumts
	    time = totaltimearray(j)
	    WRITE(string,'(ES10.3,1X)') time
	    currname = obspts(i)%name
          WRITE (200,58) '"', currname, '"', time,
     $                     (calcvalarray(i,j,m), m = 1, numspecies)
58	    FORMAT (A1, A50, A1, 1X, 24ES23.15)  !emrl changed A8 to A50 so
	  END DO                                 !emrl to increase Obs pt names
	END DO
	CLOSE(200)

	DEALLOCATE (c)
	DEALLOCATE (b)
	DEALlOCATE (b2)

	ENDSUBROUTINE ForwardRun

	SUBROUTINE FinalDataTweaking(a)
	! here some last preparations are made before running ART3D

	USE globaldata
	IMPLICIT NONE
	DOUBLE PRECISION a(numspecies,numspecies)
	INTEGER i, j

	! determine alphay and alphaz from the input ratios
	aquiferdata(4)%current = aquiferdata(6)%current * 
     $                                       aquiferdata(3)%current
	aquiferdata(4)%start = aquiferdata(6)%start * 
     $                                       aquiferdata(3)%start
	aquiferdata(5)%current = aquiferdata(7)%current * 
     $                                       aquiferdata(3)%current
	aquiferdata(5)%start = aquiferdata(7)%start * 
     $                                       aquiferdata(3)%start

	! set up 'a' matrix
	
	DO i=1,numspecies  ! multiply each yield value by the appropriate k value
	  DO j=1, numspecies
	    a(i,j) = yield(i,j) * k(j)%current
	  END DO
	END DO
	DO i=1,numspecies ! fill in the diagonal with the negative of each k value
	  a(i,i) = -k(i)%current
	END DO
	DO i = 1, numspecies ! divide each value by retardation factor
	  DO j = 1, numspecies
	    a(i,j) = a(i,j) / aquiferdata(1)%current
	  END DO
	END DO

	! adjust velocity value by dividing it by retardation factor
	aquiferdata(2)%current = aquiferdata(2)%current / 
     $			aquiferdata(1)%current

	! set up source locations
	xsloc = 0
	ysloc = (((grid%ny-1)/2))*grid%dy


	END SUBROUTINE FinalDataTweaking
	
	SUBROUTINE ErrorMessageAndStop(code, card)
	! error messages
	IMPLICIT NONE
	INTEGER code
	CHARACTER card*10

	IF (code == 1) THEN
	  WRITE (*,*) "Error opening *.art file."
	ELSE IF (code == 2) THEN
	  WRITE (*,*) "Memory error."
	ELSE IF (code == 3) THEN
	  WRITE (*,*) "This is not a valid ART3D simulation file."
	ELSE IF (code == 4) THEN
	  WRITE (*,*) "Error in ", card, " card."
	ELSE IF (code == 5) THEN
	  WRITE (*,*) "Error opening gridfile."
	ELSE IF (code == 6) THEN
	  WRITE (*,*) "Grid file erre in ", card, " card."
	ELSE IF (code == 7) THEN
	  WRITE (*,*) "Error in the ", card, " line of the PARAM card."
	ELSE IF (code == 8) THEN
	  WRITE (*,*) "Error opening output data file for species ",
     $                 card, "."
	ELSE IF (code == 9) THEN
	  WRITE (*,*) "Error opening timeseries output file for writing."
	ELSE IF (code == 10) THEN
	  WRITE (*,*) "Error opening parameter file for writing."
	ELSE IF (code == 11) THEN
	  WRITE (*,*) "Error: Check the max and min values for ",card,"."
	END IF

	WRITE (*,*) "Press Enter"
	READ (*,*)
	STOP

	END SUBROUTINE ErrorMessageAndStop

	SUBROUTINE ObservationDomenico(i,j,ik,t,c0,localk,c)

	! this routine is the same as Domenico (written by Cristhian) except it solves for a single
	! observation point instead of for each point in the grid
	USE globaldata
	IMPLICIT NONE
      double precision localk,derfc,derf,x1,x2
	DOUBLE PRECISION i,j,ik,x,y,z,cc,t,hx2,h1,hx1,hx4,h2,hx3,hx,fy,fz
	DOUBLE PRECISION c,c0
	
c Domenico Anlaytical Solution is used as in Martin-Hayden and Robbins paper
c See equations 5 & 1 in GW vol.35(2), 1997, pages p.345 and 340.
	cc = DSQRT(1.+(4.*localk*aquiferdata(3)%current/
     $                                aquiferdata(2)%current))
	z=(ik*grid%dz) 
	y=j*grid%dy-ysloc
	x=(i+1)*grid%dx-xsloc !add the extra 1 because Subroutine Domenico
	!  doesn't solve for the first column.  Also because this routine 
	!  breaks down if x = 0
	x1=(x - aquiferdata(2)%current*t*cc)/(2*
     $				DSQRT(aquiferdata(2)%current*
     $				aquiferdata(3)%current*t))
	hx2=DERFC(x1)
	IF (hx2 .LE. 1.0e-30) THEN
        h1 = 0.0
      ELSE
        hx1=DEXP((x*(1.-cc))/(2.*aquiferdata(3)%current))
        h1=hx1*hx2
      END IF
	x1=(x + aquiferdata(2)%current*t*cc)/(2*
     $							DSQRT(aquiferdata(3)%current*
     $							aquiferdata(2)%current*t))
      hx4=DERFC(x1)
      IF (hx4 .LE. 1.0e-30) THEN
        h2 = 0.0
	ELSE
        hx3=DEXP((x*(1.+cc))/(2.*aquiferdata(3)%current))
        h2=hx3*hx4
	END IF
        hx = h1+h2
	  x1=(y+ysdim/2.0)/(2.0*DSQRT(aquiferdata(4)%current*x))
	  x2= (y-ysdim/2.0)/(2.0*DSQRT(aquiferdata(4)%current*x))   
	  fy=DERF(x1)-DERF(x2)
	IF (aquiferdata(5)%current. LE .1.0e-30) THEN
	  fz=2.0
	ELSE
	  x1=(z+zsdim)/(2.0*DSQRT(aquiferdata(5)%current*x))
	  x2=(z-zsdim)/(2.0*DSQRT(aquiferdata(5)%current*x))
	  fz= DERF(x1)-DERF(x2)
	ENDIF
	c=(c0/8.0)*hx*fy*fz

      END SUBROUTINE ObservationDomenico

	! END OF CMH CHANGES.  The rest of this is exactly as written by Cristhian.

!     MODE BATCH
      Subroutine Batch(n,na,m,lda,lwork,nvec)
      DOUBLE PRECISION A(NA,N),EVR(N),EVI(N),VECS(NA,N),SCR1(N),SCR2(N)
      DOUBLE PRECISION ipiv(N),work(LWORK)
      DOUBLE PRECISION aux(n,n),s(n,n),sinv(n,n),sum
	DOUBLE PRECISION k	
      Dimension c(n),b(n),co(n),bo(n)  
	Character tdata*256


	READ (5,*) tdata
      Read (5,*) num1,num2,num3,num4,tdata
	Read (5,*) num1,num2,num3,tdata
      

!     Reading K matrix
      READ (5,*) tdata	      
	Do i=1,n 
        READ (5,*) (a(i,j),j=1,n),tdata
	end do

!      Reading Observation Time
      READ (5,*) tdata
	READ (5,*) tf,tdata
	Read (5,*) tdata
      Read (5,*) num1,num2,num3,num4,num5,tdata
	Read (5,*) num1,num2,tdata


!      Reading Initial Concentration
      READ (5,*) tdata
	Do i=1,n 
        READ (5,*) co(i),tdata
	end do

!      Printing on Screen	K matrix
      Write(*,*)" "
      Write(*,*)"K Matrix "
	Do i=1,n
            write (*,1) (a(i,j), j=1,n)  ! K matrix
1           Format(9ES8.1) 
	End do
	Pause	

!      Calculate eigenvalues and eigenvectors

      CALL EIGEN (NVEC,NA,N,A,EVR,EVI,VECS,SCR1,SCR2,IERR)
	If (ierr.eq.0) then 
          write (*,*) "Calculation of Eigenvectors :  OK."
	Else
          write (*,*) "Calculation of Eigenvectors :  Fail"
	end if
      do j=1, n
         do i = 1, n
            s(i,j)=vecs(i,j)       ! S matrix
	      a(i,j)=vecs(i,j)
         end do
      end do


!      Calculate Inverse of S
      Call DGETRF( M, N, A, LDA, IPIV, INFO )
	write (*,*) " "
	If (info.eq.0) then 
            write (*,*) "Descomposition LU :  OK."
	Else
            write (*,*) "Descomposition LU :  Fail"
	end if
      Call DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
	write (*,*) " "
	If (ierr.eq.0) then 
            write (*,*) "Calculation of Inverse of S  :  OK."
	Else
            write (*,*) "Calculation of Inverse of S  :  Fail"
	end if
	write (*,*) " "
      do j=1, n
         do i = 1, n
            sinv(i,j) = a(i,j)       !   s-1 matrix
         end do
      end do


!      Printing on Screen	S matrix
	Write (*,*) " S Matrix"
        do i = 1, n
             write (*,6) (s(i,j),j=1,n)  ! eigenvectors
         end do
6        Format  (9ES8.1)
	PAUSE


!      Printing on Screen	S-1 matrix
      Write (*,*) " S-1 Matrix"
      do i = 1, n
            write (*,8) (sinv(i,j),j=1,n)
8           Format(9ES8.1) 
      end do
	Pause
 
 
 !    Calculating S*S-1
      do i = 1, n
         do j = 1, n
            sum = 0.0
            do l = 1, n
                sum = sum +s(i,l)*sinv(l,j)     !(s)*(s-1)=1
		  end do
            a(i,j) = sum
          end do
      end do
      write (*,*) "Identity Matrix"
      do i = 1, n
         write (*,13) (a(i,j),j=1,n)
13	   Format (9f8.4)
      end do
    
	Do i=1,n
		sum=0.0
	    Do j=1,n
	      sum=sum+abs(a(i,j))
		Enddo
	    If (sum>1+n*0.001) then
		  Write(*,*)" "
	      Write(*,*)" There is a problem in Row Number:",i
		  Write (*,*)" Look through the input data"
		  Write(*,*)" "
		end if
	Enddo	



c      Transform Initial condition
       do i = 1, n
          sum = 0.0
          do l = 1, n
             sum = sum +sinv(i,l)*co(l)
          end do
          bo(i) = sum
       end do
      

c
c      Solve the problem in the "b" domain (BATCH SOLUTION)

       OPEN(10,FILE="solution.out",FORM='FORMATTED',STATUS='UNKNOWN')
	 Do time=0,tf*2
           DO i = 1, n
	         b(i)=bo(i)*dexp(evr(i)*time/2)
           END DO


c      Transfer the solution back to the "c" domain
       
	     Do ic=1,n
	        sum=0.0
		    Do l=1,n
		       sum=sum+s(ic,l)*b(l)
		    end do
		    c(ic)=sum
	     end do

c      Output solution
	     write (10,19) time/2,(c(ic),ic=1,n)
19	     format(f10.2,9e15.5)
			 
      End do 
  	END Subroutine Batch


!      MODE TRANSPORT
	Subroutine Bcgms(nx,ny,nz,nt,n,na,m,lda,lwork,nvec,c,b)
	IMPLICIT NONE
	Double Precision dx,dy,dz
      Character tdata*256
	Integer n,nx,ny,nz, indtime
	Integer nvec,na,ierr,m,lda,info,lwork,nt
	Integer i,j,l,sp,it,ik,ic,ix
	Double Precision A(na,n),evr(n),evi(n),vecs(na,n),scr1(n),scr2(n)
	Double Precision dt,reta,v,ax,ay,az,xsdim,ysdim,zsdim,xsloc,ysloc
	Double precision co(n),c(nx,ny,nz,n),bo(n),b(nx,ny,nz,n)
	Double Precision ixy,ixz,ixyz,zmag
	Double Precision iz,iy,time,index,sum
	Double precision s(n,n),sinv(n,n)
	Double Precision ipiv(n),work(lwork)


     
!	Reading Grid Size
      READ (5,*) dx,dy,dz,tdata
      Read (5,*) tdata

!      Reading K matrix	      
	Do i=1,n 
        READ (5,*) (a(i,j),j=1,n),tdata
	end do
	Read (5,*) tdata

!       Reading Observation Time
      Read (5,*) dt,tdata
	Read (5,*) tdata

!	Reading Transport Parameters
        READ (5,*) reta,v,ax,ay,az,tdata
	  v=v/reta

!     Matrix K divide by Retardation Factor
      Do j=1,n 
	  Do i=1,n 
        a(i,j)=a(i,j)/reta
	  end do
	End do

!	Reading Source Dimensions
        xsdim=0.0
        READ (5,*) ysdim,zsdim,tdata

!     Automatically set the source locations
      xsloc=0.0              ! source x fixed at the left boundary
	ysloc=(((ny-1)/2)+1)*dy !source y is at grid center


!      Reading Initial Concentration
      READ(5,*) tdata
	Do i=1,n 
        READ (5,*) co(i),tdata
	end do

!     Information for Plotting
      ixy=101 ! file unit numbers
	ixz=201
	ixyz=301
	zmag=10.0 ! z magnification for plotting
	write (*,*) ixy,ixz,ixyz
	CALL Gmsfiles(nx,ny,nz,n,dx,dy,dz,zmag,ixy,ixz,ixyz) 
	      
      Write (*,*) "   "	
      Write (*,*) "K matrix"
	Do i=1,n
            write (*,1) (a(i,j), j=1,n)
1           Format(9es15.3) 
	End do
		
      Pause

      CALL EIGEN (NVEC,NA,N,A,EVR,EVI,VECS,SCR1,SCR2,IERR)
	If (ierr.eq.0) then 
          write (*,*) "Calculation of Eigenvectors :  OK."
	Else
          write (*,*) "Calculation of Eigenvectors :  Fail"
	end if
      do j=1, n
         do i = 1, n
            s(i,j) = vecs(i,j)
            a(i,j) = vecs(i,j)
         end do
      end do


!      Printing on Screen	S matrix
      Write (*,*) "   "
	Write (*,*) " S Matrix"
        do i = 1, n
             write (*,6) (s(i,j),j=1,n)  ! eigenvectors
        end do
6       Format  (4ES20.10)
	PAUSE


      call DGETRF( M, N, A, LDA, IPIV, INFO )
	write (*,*) " "
	If (info.eq.0) then 
           write (*,*) "Descomposition LU :  OK."
	Else
           write (*,*) "Descomposition LU :  Fail"
	end if
      call DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
	write (*,*) " "
	If (ierr.eq.0) then 
           write (*,*) "Calculation of Inverse of S  :  OK."
	Else
           write (*,*) "Calculation of Inverse of S  :  Fail"
	end if
	write (*,*) " "
      do j=1, n
         do i = 1, n
            sinv(i,j) = a(i,j)
         end do
       end do


!      Printing on Screen	S-1 matrix
       Write (*,*) " S-1 Matrix"
         do i = 1, n
            write (*,8) (sinv(i,j),j=1,n)
8           Format(9ES8.1) 
         end do
		Pause


!    Calculating S*S-1
         do i = 1, n
            do j = 1, n
               sum = 0.0
               do l = 1, n
                  sum = sum +s(i,l)*sinv(l,j)   !(s)*(s-1)=1
               end do
               a(i,j) = sum
            end do
         end do

!      Printing on Screen I matrix
        write (*,*) "Identity Matrix"
         do i = 1, n	     
            write (*,13) (a(i,j),j=1,n)
13	      Format (9f8.4)
         end do

	Do i=1,n
		sum=0
	    Do j=1,n
	      sum=sum+abs(a(i,j))
		Enddo
	    If (sum>1+n*0.001) then
		  Write(*,*)" "
	      Write(*,*)" There is a problem in Row Number:",i
		  Write (*,*)" Look through the input data"
		  Write(*,*)" "
		end if
	Enddo	



c      Initial condition
      do l=1,dz
	   do j=1, dy
            do i = 1, dx
			do sp=1,n
				c(i,j,l,sp) = 0.0
			end do
	      end do
          end do
	end do

c      Transform boundary condition
       do i = 1, n
          sum = 0.0
          do l = 1, n
             sum = sum +sinv(i,l)*co(l)
          end do
             bo(i) = sum
       end do
	write(*,*) "B(i)= ",(bo(i),i=1,n)
       pause


c      Solve the problem in the "b" domain (DOMENICO SOLUTION)

       OPEN(10,FILE="solution.out",FORM='FORMATTED',STATUS='UNKNOWN')

	Do it=1,nt !begin time loop.
	indtime=it

       DO i = 1, n
         CALL Domenico(n,nx,ny,nz,indtime,dx,dy,dz,dt,Xsloc,Ysloc,xsdim,
     $	          ysdim,zsdim,v,ax,ay,az,bo(i),-evr(i),b(1,1,1,i))
       END DO


c      Transfer the solution back to the "c" domain
       
	 Do ik=1,nz
	     Do j=1,ny
			Do i=1,nx
				Do ic=1,n
		            sum=0
					Do l=1,n
						sum=sum+s(ic,l)*b(i,j,ik,l)
					end do
					c(i,j,ik,ic)=sum
				end do
			end do
		end do
	 end do
			 
c*******Write GMS x-y data for all species at the water table boundary**
       iz = 1 !output at the water table
       DO ic = 1, n
	   time = it*dt
           WRITE(ixy+ic,206) "TS ",0,time   
           DO iy = 1, ny
	      DO ix = 1, nx
                  WRITE(ixy+ic,208) c(ix,iy,iz,ic)
	      ENDDO
            ENDDO
        END DO

c*****Write cross sectional x-z data for all species*************
       iy = (((ny-1)/2)+1) !center line location
       DO ic = 1, n
	   time = it*dt
           WRITE(ixz+ic,206) "TS ",0,time   
           DO iz = 1, nz
	      DO ix = 1, nx
                  WRITE(ixz+ic,208) c(ix,iy,iz,ic)
	      ENDDO
            ENDDO
        END DO

c*****Write x-y-z data for all species*************
       DO ic = 1, n
	   time = it*dt
           WRITE(ixyz+ic,206) "TS ",0,time   
           DO iz = 1, nz
              DO iy = 1, ny
	         DO ix = 1, nx
                    WRITE(ixyz+ic,208) c(ix,iy,iz,ic)
	         ENDDO
               ENDDO
	   ENDDO
        END DO
206  	  FORMAT (A3,I2,F15.5)
208  	  FORMAT (1E15.5)
	

c*******Ouput centerline concentration at the water table         
	write(10,*) "Time =",it*dt
       index=(((ny-1)/2)+1)
	 DO j = 1, nx
          write (10,20) j, (c(j,index,1,l),l=1,n)
       END DO
20     FORMAT (I,10e15.5)
      
	End do  !end of time loop
  
	DO ic = 1, n
           WRITE (ixy+ic,'(A7)') "ENDDS"
    	ENDDO
	DO ic = 1, n
           WRITE (ixz+ic,'(A7)') "ENDDS"
    	ENDDO
	DO ic = 1, n
           WRITE (ixyz+ic,'(A7)') "ENDDS"
    	ENDDO

	End Subroutine Bcgms


	SUBROUTINE Domenico(n,nx,ny,nz,it,dx,dy,dz,dt,xsloc,ysloc,xsdim,
     $                      ysdim,zsdim,v,ax,ay,az,c0,k,c)

	!  this subroutine used by both the original ART3D code (Cristhian) and by that written by CMH
	Integer n,nx,ny,nz
	integer j,i,l,ik, it
	Double Precision dx,dy,dz,dt,xsloc,ysloc
	Double Precision xsdim,ysdim,zsdim,v,ax,ay,az
	Double Precision c(nx,ny,nz)
	Double Precision k,c0 
	Double Precision cc,t
	Double Precision y,x,x1,hx1,erf,hx3,hx,hx2,hx4,h1,h2,derfc,derf
	Double Precision x2,fy,fz
	
      
	DO j=1,ny             
           DO i=1,nx
			Do l=1,nz
			c(i,j,l)=0.0
			End do
	   END DO
	END DO
c Domenico Anlytical Solution is used as in Martin-Hayden and Robbins paper
c See equations 5 & 1 in GW vol.35(2), 1997, pages p.345 and 340.
	 cc = DSQRT(1.+(4.*k*ax/v))
	t=it*dt
	Do ik=1,nz
	  z=(ik-1)*dz	
        DO j=1,ny
		y=(j-1)*dy-ysloc ! was j*dy-ysloc
		DO i=1,nx               
		  x=i*dx-xsloc
		  x1=(x - v*t*cc)/(2*DSQRT(ax*v*t))
	      hx2=DERFC(x1)
		  IF (hx2 .LE. 1.0e-40) THEN
               h1 = 0.0
            ELSE
               hx1=DEXP((x*(1.-cc))/(2.*ax))
               h1=hx1*hx2
            END IF
	      x1=(x + v*t*cc)/(2*DSQRT(ax*v*t))
             hx4=DERFC(x1)
            IF (hx4 .LE. 1.0e-40) THEN
               h2 = 0.0
	    ELSE
               hx3=DEXP((x*(1.+cc))/(2.*ax))
               h2=hx3*hx4
	    END IF
            hx = h1+h2
		  x1=(y+ysdim/2.0)/(2.0*DSQRT(ay*x))
		  x2= (y-ysdim/2.0)/(2.0*DSQRT(ay*x))   
		  fy=DERF(x1)-DERF(x2)

	    IF (az. LE .1.0e-30) THEN
	       fz=2.0
	    ELSE
	       x1=(z+zsdim)/(2.0*DSQRT(az*x))
		   x2=(z-zsdim)/(2.0*DSQRT(az*x))
		    fz= DERF(x1)-DERF(x2)
	    ENDIF

! printing information for centerline , B domain
!		If ((z.eq.0).and.(y.eq.0)) then
!			write(*,*) "x :",x
!			write(*,*) " v,k,ax,t,cc :",v,k,ax,t,cc
!			write(*,*) "hx1 :", hx1
!			write(*,*) "exp(x/2ax) :",EXP((x)/(2.*ax))
!			write(*,*) "EXP(-(x*cc))/(2.*ax)) :",EXP(-(x*cc)/(2.*ax))
!		write(*,*) "hx1 (2) :",EXP((x)/(2.*ax))*EXP(-(x*cc)/(2.*ax)) 
!			write(*,*) "hx2 :", hx2
!			write(*,*) "hx4 :", hx4
!			write(*,*) "hx :",hx
!			write(*,*) "Bo :",c0
!			write(*,*) "hx*c0/2 :",hx*c0/2
!			write(*,*) "fy :",fy
!			write(*,*) "fz :",fz
!	write(*,*) " 3-d solution :  ",(c0/8.0)*hx*fy*fz
!			write(*,*) "  "
!			Pause
!		end if

	    c(i,j,ik)=(c0/8.0)*hx*fy*fz   !3D	
!	    c(i,j,ik)=(c0/2.0)*hx   !1D
	 END DO
	END DO
	END DO
      END SUBROUTINE Domenico

	

	SUBROUTINE Gmsfiles(nx,ny,nz,nc,dx,dy,dz,zmag,ixy,ixz,ixyz)
	Implicit None
	Integer nx,ny,nz,nc
	Integer i,j,ic
	Double Precision dx,dy,dz,zmag,ixy,ixz,ixyz,iz,z
	CHARACTER*11 dumchar1,flname
      CHARACTER*12 flname1
c******This routine write all gms grids for post processing*******
c*******Write GMS x-y 2-GRID file**********
   	OPEN(10,FILE="gmsxy2d.grd",FORM='FORMATTED',STATUS='UNKNOWN')
	WRITE (10,11) "GRID2D  "
	WRITE (10,11) "TYPE 0  "
        WRITE (10,11) "IJ -y +x"
        z = 0.0
        WRITE (10,12) "ORIGIN ",dx,dy,z
        WRITE (10,11) "ROTZ 0  "
	dumchar1 = "DIM"
        WRITE (10,14) dumchar1,nx,ny
	DO i = 1, nx
           WRITE(10,'(E15.5)') (i-1)*dx
	END DO
	DO j = 1, ny
           WRITE(10,'(E15.5)') (j-1)*dy
	END DO

c*******Write GMS x-z 2-GRID file**********
   	OPEN(11,FILE="gmsxz2d.grd",FORM='FORMATTED',STATUS='UNKNOWN')
	WRITE (11,11) "GRID2D  "
	WRITE (11,11) "TYPE 0  "
        WRITE (11,11) "IJ -y +x"
        WRITE (11,12) "ORIGIN ",dx,dz,0.0
        WRITE (11,11) "ROTZ 0  "
	dumchar1 = "DIM"
        WRITE (11,14) dumchar1,nx,nz
	DO i = 1, nx
           WRITE(11,'(E15.5)') (i-1)*dx
	END DO
	DO j = 1, nz
           WRITE(11,'(E15.5)') (j-1)*dz*zmag
	END DO

c*******Write GMS xyz 3-GRID file***************
   	OPEN(12,FILE="gmsxyz3d.grd",FORM='FORMATTED',STATUS='UNKNOWN')
	WRITE (12,11) "GRID3D  "
	WRITE (12,11) "TYPE 0  "
        WRITE (12,13) "IJK -y +x -Z"
        WRITE (12,12) "ORIGIN ",dx, dy, dz
        WRITE (12,11) "ROTZ 0  "
	dumchar1 = "DIM"
        WRITE (12,15) dumchar1,nx,ny,nz
	DO i = 1, nx
           WRITE(12,'(E15.5)') (i-1)*dx
	END DO
	DO j = 1, ny
           WRITE(12,'(E15.5)') (j-1)*dy
	END DO
	DO j = 1, nz
           WRITE(12,'(E15.5)') (j-1)*dz
	END DO

c******Open and write headers for xy-data files***********
	iz = 1 !fix layer
   	flname='conxyxx.scl'
c	NCOL = NX !60
c	NROW = NY !31
      	DO ic = 1, nc
           WRITE(flname(6:7),'(i2.2)') ic
	   OPEN(UNIT=ixy+ic,FILE=flname,FORM='Formatted',
     $     STATUS='Unknown')	
	   WRITE (ixy+ic,'(a7)') "DATASET"
	   WRITE (ixy+ic,'(a14)') "OBJTYPE grid2d"
	   WRITE (ixy+ic,'(a6)') "BEGSCL"
	   WRITE (ixy+ic,202) "ND",nx*ny
	   WRITE (ixy+ic,202) "NC",(nx-1)*(ny-1)
	   WRITE (ixy+ic,204) "NAME ",flname
      	ENDDO
c******Open and write headers for xz-data files***********
	flname='conxzxx.scl'      
        DO ic = 1, nc
           WRITE(flname(6:7),'(i2.2)') ic
	   OPEN(UNIT=ixz+ic,FILE=flname,FORM='Formatted',
     $     STATUS='Unknown')	
	   WRITE (ixz+ic,'(a7)') "DATASET"
	   WRITE (ixz+ic,'(a14)') "OBJTYPE grid2d"
	   WRITE (ixz+ic,'(a6)') "BEGSCL"
	   WRITE (ixz+ic,202) "ND",nx*nz
	   WRITE (ixz+ic,202) "NC",(nx-1)*(nz-1)
	   WRITE (ixz+ic,204) "NAME ",flname
      ENDDO
c******Open and write headers for xyz-data files***********
	flname1='conxyzxx.scl'     
        DO ic = 1, nc
           WRITE(flname1(7:8),'(i2.2)') ic
	   OPEN(UNIT=ixyz+ic,FILE=flname1,FORM='Formatted',
     $     STATUS='Unknown')	
	   WRITE (ixyz+ic,'(a7)') "DATASET"
	   WRITE (ixyz+ic,'(a14)') "OBJTYPE grid3d"
	   WRITE (ixyz+ic,'(a6)') "BEGSCL"
	   WRITE (ixyz+ic,202) "ND",nx*ny*nz
	   WRITE (ixyz+ic,202) "NC",(nx-1)*(ny-1)*(nz-1)
	   WRITE (ixyz+ic,204) "NAME ",flname1
        ENDDO
11	  FORMAT (a8)
12	  FORMAT (a7, 3E15.5)
13	  FORMAT (a12)
14	  FORMAT (a3,1x,2I4)
15	  FORMAT (a3,1x,3I4)
202  	  FORMAT(A2,I10)
204  	  FORMAT(A5,A7)
	  RETURN
	END SUBROUTINE Gmsfiles

	     SUBROUTINE CALERF(ARG,RESULT,JINT)
C------------------------------------------------------------------
C
C This packet evaluates  erf(x),  erfc(x),  and  exp(x*x)*erfc(x)
C   for a real argument  x.  It contains three FUNCTION type
C   subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX),
C   and one SUBROUTINE type subprogram, CALERF.  The calling
C   statements for the primary entries are:
C
C                   Y=ERF(X)     (or   Y=DERF(X)),
C
C                   Y=ERFC(X)    (or   Y=DERFC(X)),
C   and
C                   Y=ERFCX(X)   (or   Y=DERFCX(X)).
C
C   The routine  CALERF  is intended for internal packet use only,
C   all computations within the packet being concentrated in this
C   routine.  The function subprograms invoke  CALERF  with the
C   statement
C
C          CALL CALERF(ARG,RESULT,JINT)
C
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALERF
C       call              ARG                  Result          JINT
C
C     ERF(ARG)      ANY REAL ARGUMENT         ERF(ARG)          0
C     ERFC(ARG)     ABS(ARG) .LT. XBIG        ERFC(ARG)         1
C     ERFCX(ARG)    XNEG .LT. ARG .LT. XMAX   ERFCX(ARG)        2
C
C   The main computation evaluates near-minimax approximations
C   from "Rational Chebyshev approximations for the error function"
C   by W. J. Cody, Math. Comp., 1969, PP. 631-638.  This
C   transportable program uses rational functions that theoretically
C   approximate  erf(x)  and  erfc(x)  to at least 18 significant
C   decimal digits.  The accuracy achieved depends on the arithmetic
C   system, the compiler, the intrinsic functions, and proper
C   selection of the machine-dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C   XMIN   = the smallest positive floating-point number.
C   XINF   = the largest positive finite floating-point number.
C   XNEG   = the largest negative argument acceptable to ERFCX;
C            the negative of the solution to the equation
C            2*exp(x*x) = XINF.
C   XSMALL = argument below which erf(x) may be represented by
C            2*x/sqrt(pi)  and above which  x*x  will not underflow.
C            A conservative value is the largest machine number X
C            such that   1.0 + X = 1.0   to machine precision.
C   XBIG   = largest argument acceptable to ERFC;  solution to
C            the equation:  W(x) * (1-0.5/x**2) = XMIN,  where
C            W(x) = exp(-x*x)/[x*sqrt(pi)].
C   XHUGE  = argument above which  1.0 - 1/(2*x*x) = 1.0  to
C            machine precision.  A conservative value is
C            1/[2*sqrt(XSMALL)]
C   XMAX   = largest acceptable argument to ERFCX; the minimum
C            of XINF and 1/[sqrt(pi)*XMIN].
C
C   Approximate values for some important machines are:
C
C                          XMIN       XINF        XNEG     XSMALL
C
C  CDC 7600      (S.P.)  3.13E-294   1.26E+322   -27.220  7.11E-15
C  CRAY-1        (S.P.)  4.58E-2467  5.45E+2465  -75.345  7.11E-15
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)  1.18E-38    3.40E+38     -9.382  5.96E-8
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  2.23D-308   1.79D+308   -26.628  1.11D-16
C  IBM 195       (D.P.)  5.40D-79    7.23E+75    -13.190  1.39D-17
C  UNIVAC 1108   (D.P.)  2.78D-309   8.98D+307   -26.615  1.73D-18
C  VAX D-Format  (D.P.)  2.94D-39    1.70D+38     -9.345  1.39D-17
C  VAX G-Format  (D.P.)  5.56D-309   8.98D+307   -26.615  1.11D-16
C
C
C                          XBIG       XHUGE       XMAX
C
C  CDC 7600      (S.P.)  25.922      8.39E+6     1.80X+293
C  CRAY-1        (S.P.)  75.326      8.39E+6     5.45E+2465
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)   9.194      2.90E+3     4.79E+37
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)  26.543      6.71D+7     2.53D+307
C  IBM 195       (D.P.)  13.306      1.90D+8     7.23E+75
C  UNIVAC 1108   (D.P.)  26.582      5.37D+8     8.98D+307
C  VAX D-Format  (D.P.)   9.269      1.90D+8     1.70D+38
C  VAX G-Format  (D.P.)  26.569      6.71D+7     8.98D+307
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns  ERFC = 0      for  ARG .GE. XBIG;
C
C                       ERFCX = XINF  for  ARG .LT. XNEG;
C      and
C                       ERFCX = 0     for  ARG .GE. XMAX.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, EXP
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 19, 1990
C
C------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
      DOUBLE PRECISION
     1     A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEN,SQRPI,
     2     TWO,THRESH,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL,
     3     Y,YSQ,ZERO
      DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5)
C------------------------------------------------------------------
C  Mathematical constants
C------------------------------------------------------------------
CS    DATA FOUR,ONE,HALF,TWO,ZERO/4.0E0,1.0E0,0.5E0,2.0E0,0.0E0/,
CS   1     SQRPI/5.6418958354775628695E-1/,THRESH/0.46875E0/,
CS   2     SIXTEN/16.0E0/
      DATA FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/,
     1     SQRPI/5.6418958354775628695D-1/,THRESH/0.46875D0/,
     2     SIXTEN/16.0D0/
C------------------------------------------------------------------
C  Machine-dependent constants
C------------------------------------------------------------------
CS    DATA XINF,XNEG,XSMALL/3.40E+38,-9.382E0,5.96E-8/,
CS   1     XBIG,XHUGE,XMAX/9.194E0,2.90E3,4.79E37/
	    DATA XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/,
     1     XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
C------------------------------------------------------------------
C  Coefficients for approximation to  erf  in first interval
C------------------------------------------------------------------
CS    DATA A/3.16112374387056560E00,1.13864154151050156E02,
CS   1       3.77485237685302021E02,3.20937758913846947E03,
CS   2       1.85777706184603153E-1/
CS    DATA B/2.36012909523441209E01,2.44024637934444173E02,
CS   1       1.28261652607737228E03,2.84423683343917062E03/
      DATA A/3.16112374387056560D00,1.13864154151050156D02,
     1       3.77485237685302021D02,3.20937758913846947D03,
     2       1.85777706184603153D-1/
      DATA B/2.36012909523441209D01,2.44024637934444173D02,
     1       1.28261652607737228D03,2.84423683343917062D03/
C------------------------------------------------------------------
C  Coefficients for approximation to  erfc  in second interval
C------------------------------------------------------------------
CS    DATA C/5.64188496988670089E-1,8.88314979438837594E0,
CS   1       6.61191906371416295E01,2.98635138197400131E02,
CS   2       8.81952221241769090E02,1.71204761263407058E03,
CS   3       2.05107837782607147E03,1.23033935479799725E03,
CS   4       2.15311535474403846E-8/
CS    DATA D/1.57449261107098347E01,1.17693950891312499E02,
CS   1       5.37181101862009858E02,1.62138957456669019E03,
CS   2       3.29079923573345963E03,4.36261909014324716E03,
CS   3       3.43936767414372164E03,1.23033935480374942E03/
      DATA C/5.64188496988670089D-1,8.88314979438837594D0,
     1       6.61191906371416295D01,2.98635138197400131D02,
     2       8.81952221241769090D02,1.71204761263407058D03,
     3       2.05107837782607147D03,1.23033935479799725D03,
     4       2.15311535474403846D-8/
      DATA D/1.57449261107098347D01,1.17693950891312499D02,
     1       5.37181101862009858D02,1.62138957456669019D03,
     2       3.29079923573345963D03,4.36261909014324716D03,
     3       3.43936767414372164D03,1.23033935480374942D03/
C------------------------------------------------------------------
C  Coefficients for approximation to  erfc  in third interval
C------------------------------------------------------------------
CS    DATA P/3.05326634961232344E-1,3.60344899949804439E-1,
CS   1       1.25781726111229246E-1,1.60837851487422766E-2,
CS   2       6.58749161529837803E-4,1.63153871373020978E-2/
CS    DATA Q/2.56852019228982242E00,1.87295284992346047E00,
CS   1       5.27905102951428412E-1,6.05183413124413191E-2,
CS   2       2.33520497626869185E-3/
      DATA P/3.05326634961232344D-1,3.60344899949804439D-1,
     1       1.25781726111229246D-1,1.60837851487422766D-2,
     2       6.58749161529837803D-4,1.63153871373020978D-2/
      DATA Q/2.56852019228982242D00,1.87295284992346047D00,
     1       5.27905102951428412D-1,6.05183413124413191D-2,
     2       2.33520497626869185D-3/
C------------------------------------------------------------------
      X = ARG
      Y = ABS(X)
      IF (Y .LE. THRESH) THEN
C------------------------------------------------------------------
C  Evaluate  erf  for  |X| <= 0.46875
C------------------------------------------------------------------
            YSQ = ZERO
            IF (Y .GT. XSMALL) YSQ = Y * Y
            XNUM = A(5)*YSQ
            XDEN = YSQ
            DO 20 I = 1, 3
               XNUM = (XNUM + A(I)) * YSQ
               XDEN = (XDEN + B(I)) * YSQ
   20       CONTINUE
            RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
            IF (JINT .NE. 0) RESULT = ONE - RESULT
            IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT
            GO TO 800
C------------------------------------------------------------------
C  Evaluate  erfc  for 0.46875 <= |X| <= 4.0
C------------------------------------------------------------------
         ELSE IF (Y .LE. FOUR) THEN
            XNUM = C(9)*Y
            XDEN = Y
            DO 120 I = 1, 7
               XNUM = (XNUM + C(I)) * Y
               XDEN = (XDEN + D(I)) * Y
  120       CONTINUE
            RESULT = (XNUM + C(8)) / (XDEN + D(8))
            IF (JINT .NE. 2) THEN
               YSQ = AINT(Y*SIXTEN)/SIXTEN
               DEL = (Y-YSQ)*(Y+YSQ)
               RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
            END IF
C------------------------------------------------------------------
C  Evaluate  erfc  for |X| > 4.0
C------------------------------------------------------------------
         ELSE
            RESULT = ZERO
            IF (Y .GE. XBIG) THEN
               IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GO TO 300
               IF (Y .GE. XHUGE) THEN
                  RESULT = SQRPI / Y
                  GO TO 300
               END IF
            END IF
            YSQ = ONE / (Y * Y)
            XNUM = P(6)*YSQ
            XDEN = YSQ
            DO 240 I = 1, 4
               XNUM = (XNUM + P(I)) * YSQ
               XDEN = (XDEN + Q(I)) * YSQ
  240       CONTINUE
            RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
            RESULT = (SQRPI -  RESULT) / Y
            IF (JINT .NE. 2) THEN
               YSQ = AINT(Y*SIXTEN)/SIXTEN
               DEL = (Y-YSQ)*(Y+YSQ)
               RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
            END IF
      END IF
C------------------------------------------------------------------
C  Fix up for negative argument, erf, etc.
C------------------------------------------------------------------
  300 IF (JINT .EQ. 0) THEN
            RESULT = (HALF - RESULT) + HALF
            IF (X .LT. ZERO) RESULT = -RESULT
         ELSE IF (JINT .EQ. 1) THEN
            IF (X .LT. ZERO) RESULT = TWO - RESULT
         ELSE
            IF (X .LT. ZERO) THEN
               IF (X .LT. XNEG) THEN
                     RESULT = XINF
                  ELSE
                     YSQ = AINT(X*SIXTEN)/SIXTEN
                     DEL = (X-YSQ)*(X+YSQ)
                     Y = EXP(YSQ*YSQ) * EXP(DEL)
                     RESULT = (Y+Y) - RESULT
               END IF
            END IF
      END IF
  800 RETURN
C---------- Last card of CALERF ----------
      END

CS    REAL FUNCTION ERF(X)
      DOUBLE PRECISION FUNCTION DERF(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for erf(x).
C   (see comments heading CALERF).
C
C   Author/date: W. J. Cody, January 8, 1985
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL             X, RESULT
      DOUBLE PRECISION X, RESULT
C------------------------------------------------------------------
      JINT = 0
      CALL CALERF(X,RESULT,JINT)
CS    ERF = RESULT
      DERF = RESULT
      RETURN
C---------- Last card of DERF ----------
      END


CS    REAL FUNCTION ERFC(X)
      DOUBLE PRECISION FUNCTION DERFC(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for erfc(x).
C   (see comments heading CALERF).
C
C   Author/date: W. J. Cody, January 8, 1985
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL             X, RESULT
      DOUBLE PRECISION X, RESULT
C------------------------------------------------------------------
      JINT = 1
      CALL CALERF(X,RESULT,JINT)
CS    ERFC = RESULT
      DERFC = RESULT
      RETURN
C---------- Last card of DERFC ----------
      END


CS    REAL FUNCTION ERFCX(X)
      DOUBLE PRECISION FUNCTION DERFCX(X)
C------------------------------------------------------------------
C
C This subprogram computes approximate values for exp(x*x) * erfc(x).
C   (see comments heading CALERF).
C
C   Author/date: W. J. Cody, March 30, 1987
C
C------------------------------------------------------------------
      INTEGER JINT
CS    REAL             X, RESULT
      DOUBLE PRECISION X, RESULT
C------------------------------------------------------------------
      JINT = 2
      CALL CALERF(X,RESULT,JINT)
CS    ERFCX = RESULT
      DERFCX = RESULT
      RETURN
C---------- Last card of DERFCX ----------
      END
	
	      SUBROUTINE EIGEN (NVEC,NA,N,A,EVR,EVI,VECS,SCR1,SCR2,IERR)
      INTEGER NVEC,NA,N,IERR
      DOUBLE PRECISION A(NA,N),EVR(N),EVI(N),VECS(NA,N),SCR1(N),SCR2(N)
C
C     ***** PURPOSE:
C     THIS SUBROUTINE COMPUTES THE EIGENVALUES AND EIGENVECTORS
C     (IF DESIRED) OF A REAL GENERAL MATRIX A BY THE DOUBLE FRANCIS
C     QR ALGORITHM AS IMPLEMENTED IN EISPACK.
C     REFERENCE:    SMITH, B.T., ET. AL., MATRIX EIGENSYSTEM ROUTINES--
C                   EISPACK GUIDE, SECOND EDITION, LECTURE NOTES IN
C                   COMPUTER SCIENCE, VOL. 6, SPRINGER-VERLAG, 1976.
C
C     ON ENTRY:
C
C        NVEC   INTEGER
C               SET = 0 IF NO EIGENVECTORS ARE DESIRED, I.E., TO
C               COMPUTE EIGENVALUES ONLY; OTHERWISE SET TO ANY
C               NONZERO INTEGER IF BOTH EIGENVALUES AND EIGENVECTORS
C               ARE DESIRED.
C
C        NA     INTEGER
C               ROW DIMENSION OF THE ARRAYS CONTAINING A AND VECS
C               AS DECLARED IN THE MAIN CALLING PROGRAM.
C
C        N      INTEGER
C               THE ORDER OF THE MATRIX A.
C
C        A      DOUBLE PRECISION(NA,N)
C               A REAL GENERAL MATRIX WHOSE EIGENVALUES AND EIGEN-
C               VECTORS (IF DESIRED) ARE TO BE COMPUTED.
C
C     ON RETURN:
C
C        EVR    DOUBLE PRECISION(N)
C               THE REAL PARTS OF THE EIGENVALUES OF A.
C
C        EVI    DOUBLE PRECISION(N)
C               THE CORRESPONDING IMAGINARY PARTS OF THE EIGENVALUES
C               OF A.  NOTE THAT COMPLEX CONJUGATE PAIRS OF EIGENVALUES
C               APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING THE
C               POSITIVE IMAGINARY PART FIRST.
C
C        VECS   DOUBLE PRECISION(NA,N)
C               IF NVEC IS NONZERO, THIS ARRAY CONTAINS THE REAL AND
C               IMAGINARY PARTS OF THE EIGENVECTORS OF A.  IF THE J-TH
C               EIGENVALUE IS REAL, THE J-TH COLUMN OF VECS CONTAINS
C               THE CORRESPONDING EIGENVECTOR (NORMALIZED TO HAVE
C               EUCLIDEAN OR 2- NORM = 1 AND POSITIVE MAXIMUM COMP-
C               ONENT).  IF THE J-THE EIGENVALUE IS COMPLEX WITH
C               POSITIVE IMAGINARY PART, THE J-TH AND (J+1)-TH
C               COLUMNS OF VECS CONTAIN THE REAL AND IMAGINARY
C               PARTS OF THE CORRESPONDING COMPLEX EIGENVECTOR
C               (NORMALIZED TO HAVE COMPLEX EUCLIDEAN OR 2- NORM
C               =1 AND REAL, POSITIVE MAXIMUM COMPONENT).  THE CONJ-
C               UGATE OF THIS VECTOR IS THE EIGENVECTOR FOR THE
C               CONJUGATE EIGENVALUE.
C
C        SCR1   DOUBLE PRECISION(N)
C               THE I-TH COMPONENT OF THIS VECTOR CONTAINS THE
C               UNDAMPED NATURAL FREQUENCY (MODULUS) OF THE I-TH
C               EIGENVALUE;  SCR1 IS ALSO USED INTERNALLY
C               AS A SCRATCH VECTOR FOR THE EISPACK SUBROUTINE
C               BALANC.
C
C        SCR2   DOUBLE PRECISION(N)
C               THE I-TH COMPONENT OF THIS VECTOR CONTAINS THE
C               DAMPING RATIO OF THE I-TH EIGENVALUE;  SCR2 IS ALSO
C               USED INTERNALLY AS A SCRATCH VECTOR FOR THE
C               EISPACK SUBROUTINE ORTHES.
C
C        IERR   INTEGER
C               ERROR COMPLETION CODE RETURNED BY EISPACK SUBROUTINE
C               HQR OR HQR2.  NORMAL RETURN VALUE IS ZERO.  SEE THE
C               EISPACK GUIDE, P. 331, FOR A DISCUSSION OF NONZERO
C               VALUES OF IERR.
C
C     PROGRAM WRITTEN BY ALAN J. LAUB, DEP'T. OF ELEC. AND COMP.ENGRG.,
C     UNIVERSITY OF CALIFORNIA, SANTA BARBARA, CA 93106,
C     PH.: (805) 961-3616.
C     JUNE 1981.
C     MOST RECENT MODIFICATION: JAN. 2, 1985
C
C     INTERNAL VARIABLES:
C
      INTEGER I,IGH,J,JM1,K,LOW
      DOUBLE PRECISION ANORM,EI,EPS,EPSP1,ER,T,TIM,TRE,T1,T2
C
C     FORTRAN FUNCTIONS CALLED:
C
      DOUBLE PRECISION DABS,DSQRT
C
C     SUBROUTINES AND FUNCTIONS CALLED:
C
C     BALANC,BALBAK,HQR,HQR2,ORTHES,ORTRAN (ALL FROM EISPACK)
C
C     ------------------------------------------------------------------
C
C     DETERMINE MACHINE PRECISION
C
      EPS = 1.0D0
   10 CONTINUE
      EPS = EPS/2.0D0
      EPSP1 = EPS+1.0D0
      IF (EPSP1 .GT. 1.0D0) GO TO 10
      EPS = 2.0D0*EPS
C
C     BALANCE A
C
      CALL BALANC (NA,N,A,LOW,IGH,SCR1)
C
C     COMPUTE 1-NORM OF THE BALANCED A
C
      ANORM = 0.0D0
      DO 30 J = 1,N
         T = 0.0D0
         DO 20 I = 1,N
            T = T+DABS(A(I,J))
   20    CONTINUE
         IF (T .GT. ANORM) ANORM = T
   30 CONTINUE
C
C     REDUCE A TO UPPER HESSENBERG FORM
C
      CALL ORTHES (NA,N,LOW,IGH,A,SCR2)
      IF (NVEC .NE. 0) GO TO 40
C
C     COMPUTE EIGENVALUES USING QR ALGORITHM
C
      CALL HQR (NA,N,LOW,IGH,A,EVR,EVI,IERR)
      IF (IERR .NE. 0) RETURN
      GO TO 110
   40 CONTINUE
C
C     COMPUTE EIGENVALUES AND EIGENVECTORS USING QR ALGORITHM
C
      CALL ORTRAN (NA,N,LOW,IGH,A,SCR2,VECS)
      CALL HQR2 (NA,N,LOW,IGH,A,EVR,EVI,VECS,IERR)
      IF (IERR .NE. 0) RETURN
      CALL BALBAK (NA,N,LOW,IGH,SCR1,N,VECS)
C
C     NORMALIZE EIGENVECTORS TO HAVE EUCLIDEAN OR 2- NORM EQUAL TO 1
C
      DO 100 J = 1,N
         IF (EVI(J) .NE. 0.0D0) GO TO 70
         T = 0.0D0
         T1 = 0.0D0
         DO 50 I = 1,N
            T2 = VECS(I,J)**2
            IF (T2 .LE. T1) GO TO 45
            K = I
            T1 = T2
   45       CONTINUE
            T = T+T2
   50    CONTINUE
         T = DSIGN(DSQRT(T),VECS(K,J))
         DO 60 I = 1,N
            VECS(I,J) = VECS(I,J)/T
   60    CONTINUE
         GO TO 100
   70    CONTINUE
         IF (EVI(J) .GT. 0.0D0) GO TO 100
         JM1 = J-1
         T = 0.0D0
         T1 = 0.0D0
         DO 80 I = 1,N
            T2 = VECS(I,JM1)**2 + VECS(I,J)**2
            IF (T2 .LE. T1) GO TO 75
            K = I
            T1 = T2
   75       CONTINUE
            T = T+T2
   80    CONTINUE
         T = DSQRT(T)
         T1 = DSQRT(T1)
         DO 90 I = 1,N
            TRE = VECS(I,JM1)*VECS(K,JM1) + VECS(I,J)*VECS(K,J)
            TIM = VECS(I,J)*VECS(K,JM1) - VECS(I,JM1)*VECS(K,J)
            VECS(I,JM1) = (TRE/T1)/T
            VECS(I,J) = (TIM/T1)/T
   90    CONTINUE
  100 CONTINUE
  110 CONTINUE
C
C     COMPUTE NATURAL FREQUENCIES AND DAMPING RATIOS.  SET
C     EIGENVALUES WITH NORM LESS THAN EPS*ANORM TO (0.0D0,0.0D0)
C
      EPS = EPS*ANORM
      DO 130 I = 1,N
         T = DABS(EVR(I))+DABS(EVI(I))
         IF (T .GT. EPS) GO TO 120
         EVR(I) = 0.0D0
         EVI(I) = 0.0D0
         SCR1(I) = 0.0D0
         SCR2(I) = 1.0D0
         GO TO 130
  120    CONTINUE
         ER = EVR(I)/T
         EI = EVI(I)/T
         SCR1(I) = DSQRT(ER**2 + EI**2)
         SCR2(I) = -ER/SCR1(I)
         SCR1(I) = T*SCR1(I)
         IF (DABS(EVI(I)) .LT. EPS) EVI(I) = 0.0D0
  130 CONTINUE
      RETURN
      END

      subroutine balanc(nm,n,a,low,igh,scale)
c
      integer i,j,k,l,m,n,nm,igh,low,iexc
      real*8 a(nm,n),scale(n)
      real*8 c,f,g,r,s,b2,radix
      logical noconv
c
c     this subroutine is a translation of the algol procedure balance,
c     num. math. 13, 293-304(1969) by parlett and reinsch.
c     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
c
c     this subroutine balances a real matrix and isolates
c     eigenvalues whenever possible.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the input matrix to be balanced.
c
c     on output
c
c        a contains the balanced matrix.
c
c        low and igh are two integers such that a(i,j)
c          is equal to zero if
c           (1) i is greater than j and
c           (2) j=1,...,low-1 or i=igh+1,...,n.
c
c        scale contains information determining the
c           permutations and scaling factors used.
c
c     suppose that the principal submatrix in rows low through igh
c     has been balanced, that p(j) denotes the index interchanged
c     with j during the permutation step, and that the elements
c     of the diagonal matrix used are denoted by d(i,j).  then
c        scale(j) = p(j),    for j = 1,...,low-1
c                 = d(j,j),      j = low,...,igh
c                 = p(j)         j = igh+1,...,n.
c     the order in which the interchanges are made is n to igh+1,
c     then 1 to low-1.
c
c     note that 1 is returned for igh if igh is zero formally.
c
c     the algol procedure exc contained in balance appears in
c     balanc  in line.  (note that the algol roles of identifiers
c     k,l have been reversed.)
c
c     Questions and comments should be directed to Alan K. Cline,
c     Pleasant Valley Software, 8603 Altus Cove, Austin, TX 78759.
c     Electronic mail to cline@cs.utexas.edu.
c
c     this version dated january 1989. (for the IBM 3090vf)
c
c     ------------------------------------------------------------------
c
      radix = 16.0d0
c
      b2 = radix * radix
      k = 1
      l = n
      go to 100
c     .......... in-line procedure for row and
c                column exchange ..........
   20 scale(m) = j
      if (j .eq. m) go to 50
c
      do 30 i = 1, l
         f = a(i,j)
         a(i,j) = a(i,m)
         a(i,m) = f
   30 continue
c
      do 40 i = k, n
         f = a(j,i)
         a(j,i) = a(m,i)
         a(m,i) = f
   40 continue
c
   50 go to (80,130), iexc
c     .......... search for rows isolating an eigenvalue
c                and push them down ..........
   80 if (l .eq. 1) go to 280
      l = l - 1
c     .......... for j=l step -1 until 1 do -- ..........
  100 do 120 j = l, 1, -1
c
         do 110 i = 1, l
            if (i .eq. j) go to 110
            if (a(j,i) .ne. 0.0d0) go to 120
  110    continue
c
         m = l
         iexc = 1
         go to 20
  120 continue
c
      go to 140
c     .......... search for columns isolating an eigenvalue
c                and push them left ..........
  130 k = k + 1
c
  140 do 170 j = k, l
c
         do 150 i = k, l
            if (i .eq. j) go to 150
            if (a(i,j) .ne. 0.0d0) go to 170
  150    continue
c
         m = k
         iexc = 2
         go to 20
  170 continue
c     .......... now balance the submatrix in rows k to l ..........
      do 180 i = k, l
  180 scale(i) = 1.0d0
c     .......... iterative loop for norm reduction ..........
  190 noconv = .false.
c
      do 270 i = k, l
         c = 0.0d0
         r = 0.0d0
c
         do 200 j = k, l
            if (j .eq. i) go to 200
            c = c + dabs(a(j,i))
            r = r + dabs(a(i,j))
  200    continue
c     .......... guard against zero c or r due to underflow ..........
         if (c .eq. 0.0d0 .or. r .eq. 0.0d0) go to 270
         g = r / radix
         f = 1.0d0
         s = c + r
  210    if (c .ge. g) go to 220
         f = f * radix
         c = c * b2
         go to 210
  220    g = r * radix
  230    if (c .lt. g) go to 240
         f = f / radix
         c = c / b2
         go to 230
c     .......... now balance ..........
  240    if ((c + r) / f .ge. 0.95d0 * s) go to 270
         g = 1.0d0 / f
         scale(i) = scale(i) * f
         noconv = .true.
c
         do 250 j = k, n
  250    a(i,j) = a(i,j) * g
c
         do 260 j = 1, l
  260    a(j,i) = a(j,i) * f
c
  270 continue
c
      if (noconv) go to 190
c
  280 low = k
      igh = l
      return
      end

      subroutine orthes(nm,n,low,igh,a,ort)
c
      integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low
      double precision a(nm,n),ort(igh)
      double precision f,g,h,scale
c
c     this subroutine is a translation of the algol procedure orthes,
c     num. math. 12, 349-368(1968) by martin and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 339-358(1971).
c
c     given a real general matrix, this subroutine
c     reduces a submatrix situated in rows and columns
c     low through igh to upper hessenberg form by
c     orthogonal similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by the balancing
c          subroutine  balanc.  if  balanc  has not been used,
c          set low=1, igh=n.
c
c        a contains the input matrix.
c
c     on output
c
c        a contains the hessenberg matrix.  information about
c          the orthogonal transformations used in the reduction
c          is stored in the remaining triangle under the
c          hessenberg matrix.
c
c        ort contains further information about the transformations.
c          only elements low through igh are used.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      la = igh - 1
      kp1 = low + 1
      if (la .lt. kp1) go to 200
c
      do 180 m = kp1, la
         h = 0.0d0
         ort(m) = 0.0d0
         scale = 0.0d0
c     .......... scale column (algol tol then not needed) ..........
         do 90 i = m, igh
   90    scale = scale + dabs(a(i,m-1))
c
         if (scale .eq. 0.0d0) go to 180
         mp = m + igh
c     .......... for i=igh step -1 until m do -- ..........
         do 100 ii = m, igh
            i = mp - ii
            ort(i) = a(i,m-1) / scale
            h = h + ort(i) * ort(i)
  100    continue
c
         g = -dsign(dsqrt(h),ort(m))
         h = h - ort(m) * g
         ort(m) = ort(m) - g
c     .......... form (i-(u*ut)/h) * a ..........
         do 130 j = m, n
            f = 0.0d0
c     .......... for i=igh step -1 until m do -- ..........
            do 110 ii = m, igh
               i = mp - ii
               f = f + ort(i) * a(i,j)
  110       continue
c
            f = f / h
c
            do 120 i = m, igh
  120       a(i,j) = a(i,j) - f * ort(i)
c
  130    continue
c     .......... form (i-(u*ut)/h)*a*(i-(u*ut)/h) ..........
         do 160 i = 1, igh
            f = 0.0d0
c     .......... for j=igh step -1 until m do -- ..........
            do 140 jj = m, igh
               j = mp - jj
               f = f + ort(j) * a(i,j)
  140       continue
c
            f = f / h
c
            do 150 j = m, igh
  150       a(i,j) = a(i,j) - f * ort(j)
c
  160    continue
c
         ort(m) = scale * ort(m)
         a(m,m-1) = scale * g
  180 continue
c
  200 return
      end

      subroutine hqr(nm,n,low,igh,h,wr,wi,ierr)
C  RESTORED CORRECT INDICES OF LOOPS (200,210,230,240). (9/29/89 BSG)
c
      integer i,j,k,l,m,n,en,ll,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr
      double precision h(nm,n),wr(n),wi(n)
      double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2
      logical notlas
c
c     this subroutine is a translation of the algol procedure hqr,
c     num. math. 14, 219-231(1970) by martin, peters, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 359-371(1971).
c
c     this subroutine finds the eigenvalues of a real
c     upper hessenberg matrix by the qr method.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by the balancing
c          subroutine  balanc.  if  balanc  has not been used,
c          set low=1, igh=n.
c
c        h contains the upper hessenberg matrix.  information about
c          the transformations used in the reduction to hessenberg
c          form by  elmhes  or  orthes, if performed, is stored
c          in the remaining triangle under the hessenberg matrix.
c
c     on output
c
c        h has been destroyed.  therefore, it must be saved
c          before calling  hqr  if subsequent calculation and
c          back transformation of eigenvectors is to be performed.
c
c        wr and wi contain the real and imaginary parts,
c          respectively, of the eigenvalues.  the eigenvalues
c          are unordered except that complex conjugate pairs
c          of values appear consecutively with the eigenvalue
c          having the positive imaginary part first.  if an
c          error exit is made, the eigenvalues should be correct
c          for indices ierr+1,...,n.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the limit of 30*n iterations is exhausted
c                     while the j-th eigenvalue is being sought.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated september 1989.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      norm = 0.0d0
      k = 1
c     .......... store roots isolated by balanc
c                and compute matrix norm ..........
      do 50 i = 1, n
c
         do 40 j = k, n
   40    norm = norm + dabs(h(i,j))
c
         k = i
         if (i .ge. low .and. i .le. igh) go to 50
         wr(i) = h(i,i)
         wi(i) = 0.0d0
   50 continue
c
      en = igh
      t = 0.0d0
      itn = 30*n
c     .......... search for next eigenvalues ..........
   60 if (en .lt. low) go to 1001
      its = 0
      na = en - 1
      enm2 = na - 1
c     .......... look for single small sub-diagonal element
c                for l=en step -1 until low do -- ..........
   70 do 80 ll = low, en
         l = en + low - ll
         if (l .eq. low) go to 100
         s = dabs(h(l-1,l-1)) + dabs(h(l,l))
         if (s .eq. 0.0d0) s = norm
         tst1 = s
         tst2 = tst1 + dabs(h(l,l-1))
         if (tst2 .eq. tst1) go to 100
   80 continue
c     .......... form shift ..........
  100 x = h(en,en)
      if (l .eq. en) go to 270
      y = h(na,na)
      w = h(en,na) * h(na,en)
      if (l .eq. na) go to 280
      if (itn .eq. 0) go to 1000
      if (its .ne. 10 .and. its .ne. 20) go to 130
c     .......... form exceptional shift ..........
      t = t + x
c
      do 120 i = low, en
  120 h(i,i) = h(i,i) - x
c
      s = dabs(h(en,na)) + dabs(h(na,enm2))
      x = 0.75d0 * s
      y = x
      w = -0.4375d0 * s * s
  130 its = its + 1
      itn = itn - 1
c     .......... look for two consecutive small
c                sub-diagonal elements.
c                for m=en-2 step -1 until l do -- ..........
      do 140 mm = l, enm2
         m = enm2 + l - mm
         zz = h(m,m)
         r = x - zz
         s = y - zz
         p = (r * s - w) / h(m+1,m) + h(m,m+1)
         q = h(m+1,m+1) - zz - r - s
         r = h(m+2,m+1)
         s = dabs(p) + dabs(q) + dabs(r)
         p = p / s
         q = q / s
         r = r / s
         if (m .eq. l) go to 150
         tst1 = dabs(p)*(dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))
         tst2 = tst1 + dabs(h(m,m-1))*(dabs(q) + dabs(r))
         if (tst2 .eq. tst1) go to 150
  140 continue
c
  150 mp2 = m + 2
c
      do 160 i = mp2, en
         h(i,i-2) = 0.0d0
         if (i .eq. mp2) go to 160
         h(i,i-3) = 0.0d0
  160 continue
c     .......... double qr step involving rows l to en and
c                columns m to en ..........
      do 260 k = m, na
         notlas = k .ne. na
         if (k .eq. m) go to 170
         p = h(k,k-1)
         q = h(k+1,k-1)
         r = 0.0d0
         if (notlas) r = h(k+2,k-1)
         x = dabs(p) + dabs(q) + dabs(r)
         if (x .eq. 0.0d0) go to 260
         p = p / x
         q = q / x
         r = r / x
  170    s = dsign(dsqrt(p*p+q*q+r*r),p)
         if (k .eq. m) go to 180
         h(k,k-1) = -s * x
         go to 190
  180    if (l .ne. m) h(k,k-1) = -h(k,k-1)
  190    p = p + s
         x = p / s
         y = q / s
         zz = r / s
         q = q / p
         r = r / p
         if (notlas) go to 225
c     .......... row modification ..........
         do 200 j = k, EN
            p = h(k,j) + q * h(k+1,j)
            h(k,j) = h(k,j) - p * x
            h(k+1,j) = h(k+1,j) - p * y
  200    continue
c
         j = min0(en,k+3)
c     .......... column modification ..........
         do 210 i = L, j
            p = x * h(i,k) + y * h(i,k+1)
            h(i,k) = h(i,k) - p
            h(i,k+1) = h(i,k+1) - p * q
  210    continue
         go to 255
  225    continue
c     .......... row modification ..........
         do 230 j = k, EN
            p = h(k,j) + q * h(k+1,j) + r * h(k+2,j)
            h(k,j) = h(k,j) - p * x
            h(k+1,j) = h(k+1,j) - p * y
            h(k+2,j) = h(k+2,j) - p * zz
  230    continue
c
         j = min0(en,k+3)
c     .......... column modification ..........
         do 240 i = L, j
            p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2)
            h(i,k) = h(i,k) - p
            h(i,k+1) = h(i,k+1) - p * q
            h(i,k+2) = h(i,k+2) - p * r
  240    continue
  255    continue
c
  260 continue
c
      go to 70
c     .......... one root found ..........
  270 wr(en) = x + t
      wi(en) = 0.0d0
      en = na
      go to 60
c     .......... two roots found ..........
  280 p = (y - x) / 2.0d0
      q = p * p + w
      zz = dsqrt(dabs(q))
      x = x + t
      if (q .lt. 0.0d0) go to 320
c     .......... real pair ..........
      zz = p + dsign(zz,p)
      wr(na) = x + zz
      wr(en) = wr(na)
      if (zz .ne. 0.0d0) wr(en) = x - w / zz
      wi(na) = 0.0d0
      wi(en) = 0.0d0
      go to 330
c     .......... complex pair ..........
  320 wr(na) = x + p
      wr(en) = x + p
      wi(na) = zz
      wi(en) = -zz
  330 en = enm2
      go to 60
c     .......... set error -- all eigenvalues have not
c                converged after 30*n iterations ..........
 1000 ierr = en
 1001 return
      end


      subroutine ortran(nm,n,low,igh,a,ort,z)
c
      integer i,j,n,kl,mm,mp,nm,igh,low,mp1
      double precision a(nm,igh),ort(igh),z(nm,n)
      double precision g
c
c     this subroutine is a translation of the algol procedure ortrans,
c     num. math. 16, 181-204(1970) by peters and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 372-395(1971).
c
c     this subroutine accumulates the orthogonal similarity
c     transformations used in the reduction of a real general
c     matrix to upper hessenberg form by  orthes.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by the balancing
c          subroutine  balanc.  if  balanc  has not been used,
c          set low=1, igh=n.
c
c        a contains information about the orthogonal trans-
c          formations used in the reduction by  orthes
c          in its strict lower triangle.
c
c        ort contains further information about the trans-
c          formations used in the reduction by  orthes.
c          only elements low through igh are used.
c
c     on output
c
c        z contains the transformation matrix produced in the
c          reduction by  orthes.
c
c        ort has been altered.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
c     .......... initialize z to identity matrix ..........
      do 80 j = 1, n
c
         do 60 i = 1, n
   60    z(i,j) = 0.0d0
c
         z(j,j) = 1.0d0
   80 continue
c
      kl = igh - low - 1
      if (kl .lt. 1) go to 200
c     .......... for mp=igh-1 step -1 until low+1 do -- ..........
      do 140 mm = 1, kl
         mp = igh - mm
         if (a(mp,mp-1) .eq. 0.0d0) go to 140
         mp1 = mp + 1
c
         do 100 i = mp1, igh
  100    ort(i) = a(i,mp-1)
c
         do 130 j = mp, igh
            g = 0.0d0
c
            do 110 i = mp, igh
  110       g = g + ort(i) * z(i,j)
c     .......... divisor below is negative of h formed in orthes.
c                double division avoids possible underflow ..........
            g = (g / ort(mp)) / a(mp,mp-1)
c
            do 120 i = mp, igh
  120       z(i,j) = z(i,j) + g * ort(i)
c
  130    continue
c
  140 continue
c
  200 return
      end


      subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr)
c
      integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn,
     x        igh,itn,its,low,mp2,enm2,ierr
      double precision h(nm,n),wr(n),wi(n),z(nm,n)
      double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2
      logical notlas
c
c     this subroutine is a translation of the algol procedure hqr2,
c     num. math. 16, 181-204(1970) by peters and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 372-395(1971).
c
c     this subroutine finds the eigenvalues and eigenvectors
c     of a real upper hessenberg matrix by the qr method.  the
c     eigenvectors of a real general matrix can also be found
c     if  elmhes  and  eltran  or  orthes  and  ortran  have
c     been used to reduce this general matrix to hessenberg form
c     and to accumulate the similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by the balancing
c          subroutine  balanc.  if  balanc  has not been used,
c          set low=1, igh=n.
c
c        h contains the upper hessenberg matrix.
c
c        z contains the transformation matrix produced by  eltran
c          after the reduction by  elmhes, or by  ortran  after the
c          reduction by  orthes, if performed.  if the eigenvectors
c          of the hessenberg matrix are desired, z must contain the
c          identity matrix.
c
c     on output
c
c        h has been destroyed.
c
c        wr and wi contain the real and imaginary parts,
c          respectively, of the eigenvalues.  the eigenvalues
c          are unordered except that complex conjugate pairs
c          of values appear consecutively with the eigenvalue
c          having the positive imaginary part first.  if an
c          error exit is made, the eigenvalues should be correct
c          for indices ierr+1,...,n.
c
c        z contains the real and imaginary parts of the eigenvectors.
c          if the i-th eigenvalue is real, the i-th column of z
c          contains its eigenvector.  if the i-th eigenvalue is complex
c          with positive imaginary part, the i-th and (i+1)-th
c          columns of z contain the real and imaginary parts of its
c          eigenvector.  the eigenvectors are unnormalized.  if an
c          error exit is made, none of the eigenvectors has been found.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the limit of 30*n iterations is exhausted
c                     while the j-th eigenvalue is being sought.
c
c     calls cdiv for complex division.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      norm = 0.0d0
      k = 1
c     .......... store roots isolated by balanc
c                and compute matrix norm ..........
      do 50 i = 1, n
c
         do 40 j = k, n
   40    norm = norm + dabs(h(i,j))
c
         k = i
         if (i .ge. low .and. i .le. igh) go to 50
         wr(i) = h(i,i)
         wi(i) = 0.0d0
   50 continue
c
      en = igh
      t = 0.0d0
      itn = 30*n
c     .......... search for next eigenvalues ..........
   60 if (en .lt. low) go to 340
      its = 0
      na = en - 1
      enm2 = na - 1
c     .......... look for single small sub-diagonal element
c                for l=en step -1 until low do -- ..........
   70 do 80 ll = low, en
         l = en + low - ll
         if (l .eq. low) go to 100
         s = dabs(h(l-1,l-1)) + dabs(h(l,l))
         if (s .eq. 0.0d0) s = norm
         tst1 = s
         tst2 = tst1 + dabs(h(l,l-1))
         if (tst2 .eq. tst1) go to 100
   80 continue
c     .......... form shift ..........
  100 x = h(en,en)
      if (l .eq. en) go to 270
      y = h(na,na)
      w = h(en,na) * h(na,en)
      if (l .eq. na) go to 280
      if (itn .eq. 0) go to 1000
      if (its .ne. 10 .and. its .ne. 20) go to 130
c     .......... form exceptional shift ..........
      t = t + x
c
      do 120 i = low, en
  120 h(i,i) = h(i,i) - x
c
      s = dabs(h(en,na)) + dabs(h(na,enm2))
      x = 0.75d0 * s
      y = x
      w = -0.4375d0 * s * s
  130 its = its + 1
      itn = itn - 1
c     .......... look for two consecutive small
c                sub-diagonal elements.
c                for m=en-2 step -1 until l do -- ..........
      do 140 mm = l, enm2
         m = enm2 + l - mm
         zz = h(m,m)
         r = x - zz
         s = y - zz
         p = (r * s - w) / h(m+1,m) + h(m,m+1)
         q = h(m+1,m+1) - zz - r - s
         r = h(m+2,m+1)
         s = dabs(p) + dabs(q) + dabs(r)
         p = p / s
         q = q / s
         r = r / s
         if (m .eq. l) go to 150
         tst1 = dabs(p)*(dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))
         tst2 = tst1 + dabs(h(m,m-1))*(dabs(q) + dabs(r))
         if (tst2 .eq. tst1) go to 150
  140 continue
c
  150 mp2 = m + 2
c
      do 160 i = mp2, en
         h(i,i-2) = 0.0d0
         if (i .eq. mp2) go to 160
         h(i,i-3) = 0.0d0
  160 continue
c     .......... double qr step involving rows l to en and
c                columns m to en ..........
      do 260 k = m, na
         notlas = k .ne. na
         if (k .eq. m) go to 170
         p = h(k,k-1)
         q = h(k+1,k-1)
         r = 0.0d0
         if (notlas) r = h(k+2,k-1)
         x = dabs(p) + dabs(q) + dabs(r)
         if (x .eq. 0.0d0) go to 260
         p = p / x
         q = q / x
         r = r / x
  170    s = dsign(dsqrt(p*p+q*q+r*r),p)
         if (k .eq. m) go to 180
         h(k,k-1) = -s * x
         go to 190
  180    if (l .ne. m) h(k,k-1) = -h(k,k-1)
  190    p = p + s
         x = p / s
         y = q / s
         zz = r / s
         q = q / p
         r = r / p
         if (notlas) go to 225
c     .......... row modification ..........
         do 200 j = k, n
            p = h(k,j) + q * h(k+1,j)
            h(k,j) = h(k,j) - p * x
            h(k+1,j) = h(k+1,j) - p * y
  200    continue
c
         j = min0(en,k+3)
c     .......... column modification ..........
         do 210 i = 1, j
            p = x * h(i,k) + y * h(i,k+1)
            h(i,k) = h(i,k) - p
            h(i,k+1) = h(i,k+1) - p * q
  210    continue
c     .......... accumulate transformations ..........
         do 220 i = low, igh
            p = x * z(i,k) + y * z(i,k+1)
            z(i,k) = z(i,k) - p
            z(i,k+1) = z(i,k+1) - p * q
  220    continue
         go to 255
  225    continue
c     .......... row modification ..........
         do 230 j = k, n
            p = h(k,j) + q * h(k+1,j) + r * h(k+2,j)
            h(k,j) = h(k,j) - p * x
            h(k+1,j) = h(k+1,j) - p * y
            h(k+2,j) = h(k+2,j) - p * zz
  230    continue
c
         j = min0(en,k+3)
c     .......... column modification ..........
         do 240 i = 1, j
            p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2)
            h(i,k) = h(i,k) - p
            h(i,k+1) = h(i,k+1) - p * q
            h(i,k+2) = h(i,k+2) - p * r
  240    continue
c     .......... accumulate transformations ..........
         do 250 i = low, igh
            p = x * z(i,k) + y * z(i,k+1) + zz * z(i,k+2)
            z(i,k) = z(i,k) - p
            z(i,k+1) = z(i,k+1) - p * q
            z(i,k+2) = z(i,k+2) - p * r
  250    continue
  255    continue
c
  260 continue
c
      go to 70
c     .......... one root found ..........
  270 h(en,en) = x + t
      wr(en) = h(en,en)
      wi(en) = 0.0d0
      en = na
      go to 60
c     .......... two roots found ..........
  280 p = (y - x) / 2.0d0
      q = p * p + w
      zz = dsqrt(dabs(q))
      h(en,en) = x + t
      x = h(en,en)
      h(na,na) = y + t
      if (q .lt. 0.0d0) go to 320
c     .......... real pair ..........
      zz = p + dsign(zz,p)
      wr(na) = x + zz
      wr(en) = wr(na)
      if (zz .ne. 0.0d0) wr(en) = x - w / zz
      wi(na) = 0.0d0
      wi(en) = 0.0d0
      x = h(en,na)
      s = dabs(x) + dabs(zz)
      p = x / s
      q = zz / s
      r = dsqrt(p*p+q*q)
      p = p / r
      q = q / r
c     .......... row modification ..........
      do 290 j = na, n
         zz = h(na,j)
         h(na,j) = q * zz + p * h(en,j)
         h(en,j) = q * h(en,j) - p * zz
  290 continue
c     .......... column modification ..........
      do 300 i = 1, en
         zz = h(i,na)
         h(i,na) = q * zz + p * h(i,en)
         h(i,en) = q * h(i,en) - p * zz
  300 continue
c     .......... accumulate transformations ..........
      do 310 i = low, igh
         zz = z(i,na)
         z(i,na) = q * zz + p * z(i,en)
         z(i,en) = q * z(i,en) - p * zz
  310 continue
c
      go to 330
c     .......... complex pair ..........
  320 wr(na) = x + p
      wr(en) = x + p
      wi(na) = zz
      wi(en) = -zz
  330 en = enm2
      go to 60
c     .......... all roots found.  backsubstitute to find
c                vectors of upper triangular form ..........
  340 if (norm .eq. 0.0d0) go to 1001
c     .......... for en=n step -1 until 1 do -- ..........
      do 800 nn = 1, n
         en = n + 1 - nn
         p = wr(en)
         q = wi(en)
         na = en - 1
         if (q) 710, 600, 800
c     .......... real vector ..........
  600    m = en
         h(en,en) = 1.0d0
         if (na .eq. 0) go to 800
c     .......... for i=en-1 step -1 until 1 do -- ..........
         do 700 ii = 1, na
            i = en - ii
            w = h(i,i) - p
            r = 0.0d0
c
            do 610 j = m, en
  610       r = r + h(i,j) * h(j,en)
c
            if (wi(i) .ge. 0.0d0) go to 630
            zz = w
            s = r
            go to 700
  630       m = i
            if (wi(i) .ne. 0.0d0) go to 640
            t = w
            if (t .ne. 0.0d0) go to 635
               tst1 = norm
               t = tst1
  632          t = 0.01d0 * t
               tst2 = norm + t
               if (tst2 .gt. tst1) go to 632
  635       h(i,en) = -r / t
            go to 680
c     .......... solve real equations ..........
  640       x = h(i,i+1)
            y = h(i+1,i)
            q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i)
            t = (x * s - zz * r) / q
            h(i,en) = t
            if (dabs(x) .le. dabs(zz)) go to 650
            h(i+1,en) = (-r - w * t) / x
            go to 680
  650       h(i+1,en) = (-s - y * t) / zz
c
c     .......... overflow control ..........
  680       t = dabs(h(i,en))
            if (t .eq. 0.0d0) go to 700
            tst1 = t
            tst2 = tst1 + 1.0d0/tst1
            if (tst2 .gt. tst1) go to 700
            do 690 j = i, en
               h(j,en) = h(j,en)/t
  690       continue
c
  700    continue
c     .......... end real vector ..........
         go to 800
c     .......... complex vector ..........
  710    m = na
c     .......... last vector component chosen imaginary so that
c                eigenvector matrix is triangular ..........
         if (dabs(h(en,na)) .le. dabs(h(na,en))) go to 720
         h(na,na) = q / h(en,na)
         h(na,en) = -(h(en,en) - p) / h(en,na)
         go to 730
  720    call cdiv(0.0d0,-h(na,en),h(na,na)-p,q,h(na,na),h(na,en))
  730    h(en,na) = 0.0d0
         h(en,en) = 1.0d0
         enm2 = na - 1
         if (enm2 .eq. 0) go to 800
c     .......... for i=en-2 step -1 until 1 do -- ..........
         do 795 ii = 1, enm2
            i = na - ii
            w = h(i,i) - p
            ra = 0.0d0
            sa = 0.0d0
c
            do 760 j = m, en
               ra = ra + h(i,j) * h(j,na)
               sa = sa + h(i,j) * h(j,en)
  760       continue
c
            if (wi(i) .ge. 0.0d0) go to 770
            zz = w
            r = ra
            s = sa
            go to 795
  770       m = i
            if (wi(i) .ne. 0.0d0) go to 780
            call cdiv(-ra,-sa,w,q,h(i,na),h(i,en))
            go to 790
c     .......... solve complex equations ..........
  780       x = h(i,i+1)
            y = h(i+1,i)
            vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q
            vi = (wr(i) - p) * 2.0d0 * q
            if (vr .ne. 0.0d0 .or. vi .ne. 0.0d0) go to 784
               tst1 = norm * (dabs(w) + dabs(q) + dabs(x)
     x                      + dabs(y) + dabs(zz))
               vr = tst1
  783          vr = 0.01d0 * vr
               tst2 = tst1 + vr
               if (tst2 .gt. tst1) go to 783
  784       call cdiv(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi,
     x                h(i,na),h(i,en))
            if (dabs(x) .le. dabs(zz) + dabs(q)) go to 785
            h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x
            h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x
            go to 790
  785       call cdiv(-r-y*h(i,na),-s-y*h(i,en),zz,q,
     x                h(i+1,na),h(i+1,en))
c
c     .......... overflow control ..........
  790       t = dmax1(dabs(h(i,na)), dabs(h(i,en)))
            if (t .eq. 0.0d0) go to 795
            tst1 = t
            tst2 = tst1 + 1.0d0/tst1
            if (tst2 .gt. tst1) go to 795
            do 792 j = i, en
               h(j,na) = h(j,na)/t
               h(j,en) = h(j,en)/t
  792       continue
c
  795    continue
c     .......... end complex vector ..........
  800 continue
c     .......... end back substitution.
c                vectors of isolated roots ..........
      do 840 i = 1, n
         if (i .ge. low .and. i .le. igh) go to 840
c
         do 820 j = i, n
  820    z(i,j) = h(i,j)
c
  840 continue
c     .......... multiply by transformation matrix to give
c                vectors of original full matrix.
c                for j=n step -1 until low do -- ..........
      do 880 jj = low, n
         j = n + low - jj
         m = min0(j,igh)
c
         do 880 i = low, igh
            zz = 0.0d0
c
            do 860 k = low, m
  860       zz = zz + z(i,k) * h(k,j)
c
            z(i,j) = zz
  880 continue
c
      go to 1001
c     .......... set error -- all eigenvalues have not
c                converged after 30*n iterations ..........
 1000 ierr = en
 1001 return
      end
      subroutine cdiv(ar,ai,br,bi,cr,ci)
      double precision ar,ai,br,bi,cr,ci
c
c     complex division, (cr,ci) = (ar,ai)/(br,bi)
c
      double precision s,ars,ais,brs,bis
      s = dabs(br) + dabs(bi)
      ars = ar/s
      ais = ai/s
      brs = br/s
      bis = bi/s
      s = brs**2 + bis**2
      cr = (ars*brs + ais*bis)/s
      ci = (ais*brs - ars*bis)/s
      return
      end

      subroutine balbak(nm,n,low,igh,scale,m,z)
c
      integer i,j,k,m,n,ii,nm,igh,low
      double precision scale(n),z(nm,m)
      double precision s
c
c     this subroutine is a translation of the algol procedure balbak,
c     num. math. 13, 293-304(1969) by parlett and reinsch.
c     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
c
c     this subroutine forms the eigenvectors of a real general
c     matrix by back transforming those of the corresponding
c     balanced matrix determined by  balanc.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by  balanc.
c
c        scale contains information determining the permutations
c          and scaling factors used by  balanc.
c
c        m is the number of columns of z to be back transformed.
c
c        z contains the real and imaginary parts of the eigen-
c          vectors to be back transformed in its first m columns.
c
c     on output
c
c        z contains the real and imaginary parts of the
c          transformed eigenvectors in its first m columns.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (m .eq. 0) go to 200
      if (igh .eq. low) go to 120
c
      do 110 i = low, igh
         s = scale(i)
c     .......... left hand eigenvectors are back transformed
c                if the foregoing statement is replaced by
c                s=1.0d0/scale(i). ..........
         do 100 j = 1, m
  100    z(i,j) = z(i,j) * s
c
  110 continue
c     ......... for i=low-1 step -1 until 1,
c               igh+1 step 1 until n do -- ..........
  120 do 140 ii = 1, n
         i = ii
         if (i .ge. low .and. i .le. igh) go to 140
         if (i .lt. low) i = low - ii
         k = scale(i)
         if (k .eq. i) go to 140
c
         do 130 j = 1, m
            s = z(i,j)
            z(i,j) = z(k,j)
            z(k,j) = s
  130    continue
c
  140 continue
c
  200 return
      end

	      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRF computes an LU factorization of a general M-by-N matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
*        Use unblocked code.
*
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
*
*        Use blocked code.
*
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
*
*           Factor diagonal and subdiagonal blocks and test for exact
*           singularity.
*
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
*           Adjust INFO and the pivot indices.
*
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
     $         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
*
*           Apply interchanges to columns 1:J-1.
*
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
            IF( J+JB.LE.N ) THEN
*
*              Apply interchanges to columns J+JB:N.
*
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
*
*              Compute block row of U.
*
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
     $                     LDA )
               IF( J+JB.LE.M ) THEN
*
*                 Update trailing submatrix.
*
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
     $                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
*
*     End of DGETRF
*
      END
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETF2 computes an LU factorization of a general m-by-n matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
*               has been completed, but the factor U is exactly
*               singular, and division by zero will occur if it is used
*               to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J, JP
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
      DO 10 J = 1, MIN( M, N )
*
*        Find pivot and test for singularity.
*
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
*
*           Apply the interchange to columns 1:N.
*
            IF( JP.NE.J )
     $         CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
*
*           Compute elements J+1:M of J-th column.
*
            IF( J.LT.M )
     $         CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
*
         ELSE IF( INFO.EQ.0 ) THEN
*
            INFO = J
         END IF
*
         IF( J.LT.MIN( M, N ) ) THEN
*
*           Update trailing submatrix.
*
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
     $                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
*
*     End of DGETF2
*
      END
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DLASWP performs a series of row interchanges on the matrix A.
*  One row interchange is initiated for each of rows K1 through K2 of A.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the matrix of column dimension N to which the row
*          interchanges will be applied.
*          On exit, the permuted matrix.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.
*
*  K1      (input) INTEGER
*          The first element of IPIV for which a row interchange will
*          be done.
*
*  K2      (input) INTEGER
*          The last element of IPIV for which a row interchange will
*          be done.
*
*  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
*          The vector of pivot indices.  Only the elements in positions
*          K1 through K2 of IPIV are accessed.
*          IPIV(K) = L implies rows K and L are to be interchanged.
*
*  INCX    (input) INTEGER
*          The increment between successive values of IPIV.  If IPIV
*          is negative, the pivots are applied in reverse order.
*
*  Further Details
*  ===============
*
*  Modified by
*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      DOUBLE PRECISION   TEMP
*     ..
*     .. Executable Statements ..
*
*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
*
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
*
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
*
      RETURN
*
*     End of DLASWP
*
      END
      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
     $                 N4 )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
*     ..
*
*  Purpose
*  =======
*
*  ILAENV is called from the LAPACK routines to choose problem-dependent
*  parameters for the local environment.  See ISPEC for a description of
*  the parameters.
*
*  This version provides a set of parameters which should give good,
*  but not optimal, performance on many of the currently available
*  computers.  Users are encouraged to modify this subroutine to set
*  the tuning parameters for their particular machine using the option
*  and problem size information in the arguments.
*
*  This routine will not function correctly if it is converted to all
*  lower case.  Converting it to all upper case is allowed.
*
*  Arguments
*  =========
*
*  ISPEC   (input) INTEGER
*          Specifies the parameter to be returned as the value of
*          ILAENV.
*          = 1: the optimal blocksize; if this value is 1, an unblocked
*               algorithm will give the best performance.
*          = 2: the minimum block size for which the block routine
*               should be used; if the usable block size is less than
*               this value, an unblocked routine should be used.
*          = 3: the crossover point (in a block routine, for N less
*               than this value, an unblocked routine should be used)
*          = 4: the number of shifts, used in the nonsymmetric
*               eigenvalue routines
*          = 5: the minimum column dimension for blocking to be used;
*               rectangular blocks must have dimension at least k by m,
*               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
*          = 6: the crossover point for the SVD (when reducing an m by n
*               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
*               this value, a QR factorization is used first to reduce
*               the matrix to a triangular form.)
*          = 7: the number of processors
*          = 8: the crossover point for the multishift QR and QZ methods
*               for nonsymmetric eigenvalue problems.
*
*  NAME    (input) CHARACTER*(*)
*          The name of the calling subroutine, in either upper case or
*          lower case.
*
*  OPTS    (input) CHARACTER*(*)
*          The character options to the subroutine NAME, concatenated
*          into a single character string.  For example, UPLO = 'U',
*          TRANS = 'T', and DIAG = 'N' for a triangular routine would
*          be specified as OPTS = 'UTN'.
*
*  N1      (input) INTEGER
*  N2      (input) INTEGER
*  N3      (input) INTEGER
*  N4      (input) INTEGER
*          Problem dimensions for the subroutine NAME; these may not all
*          be required.
*
* (ILAENV) (output) INTEGER
*          >= 0: the value of the parameter specified by ISPEC
*          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  The following conventions have been used when calling ILAENV from the
*  LAPACK routines:
*  1)  OPTS is a concatenation of all of the character options to
*      subroutine NAME, in the same order that they appear in the
*      argument list for NAME, even if they are not used in determining
*      the value of the parameter specified by ISPEC.
*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
*      that they appear in the argument list for NAME.  N1 is used
*      first, N2 second, and so on, and unused problem dimensions are
*      passed a value of -1.
*  3)  The parameter value returned by ILAENV is checked for validity in
*      the calling subroutine.  For example, ILAENV is used to retrieve
*      the optimal blocksize for STRTRI as follows:
*
*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
*      IF( NB.LE.1 ) NB = MAX( 1, N )
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            CNAME, SNAME
      CHARACTER*1        C1
      CHARACTER*2        C2, C4
      CHARACTER*3        C3
      CHARACTER*6        SUBNAM
      INTEGER            I, IC, IZ, NB, NBMIN, NX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
*     ..
*     .. Executable Statements ..
*
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
*
*     Invalid value for ISPEC
*
      ILAENV = -1
      RETURN
*
  100 CONTINUE
*
*     Convert NAME to upper case if the first character is lower case.
*
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
*
*        ASCII character set
*
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 10 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   10       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
*
*        EBCDIC character set
*
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $       ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1:1 ) = CHAR( IC+64 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $             ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $             ( IC.GE.162 .AND. IC.LE.169 ) )
     $            SUBNAM( I:I ) = CHAR( IC+64 )
   20       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
*
*        Prime machines:  ASCII+128
*
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   30       CONTINUE
         END IF
      END IF
*
      C1 = SUBNAM( 1:1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )
     $   RETURN
      C2 = SUBNAM( 2:3 )
      C3 = SUBNAM( 4:6 )
      C4 = C3( 2:3 )
*
      GO TO ( 110, 200, 300 ) ISPEC
*
  110 CONTINUE
*
*     ISPEC = 1:  block size
*
*     In these examples, separate code is provided for setting NB for
*     real and complex.  We assume that NB will take the same value in
*     single or double precision.
*
      NB = 1
*
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
*
  200 CONTINUE
*
*     ISPEC = 2:  minimum block size
*
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 8
            ELSE
               NBMIN = 8
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
*
  300 CONTINUE
*
*     ISPEC = 3:  crossover point
*
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
*
  400 CONTINUE
*
*     ISPEC = 4:  number of shifts (used by xHSEQR)
*
      ILAENV = 6
      RETURN
*
  500 CONTINUE
*
*     ISPEC = 5:  minimum column dimension (not used)
*
      ILAENV = 2
      RETURN
*
  600 CONTINUE 
*
*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
*
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
*
  700 CONTINUE
*
*     ISPEC = 7:  number of processors (not used)
*
      ILAENV = 1
      RETURN
*
  800 CONTINUE
*
*     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
*
      ILAENV = 50
      RETURN
*
*     End of ILAENV
*
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER*6        SRNAME
      INTEGER            INFO
*     ..
*
*  Purpose
*  =======
*
*  XERBLA  is an error handler for the LAPACK routines.
*  It is called by an LAPACK routine if an input parameter has an
*  invalid value.  A message is printed and execution stops.
*
*  Installers may consider modifying the STOP statement in order to
*  call system-specific exception-handling facilities.
*
*  Arguments
*  =========
*
*  SRNAME  (input) CHARACTER*6
*          The name of the routine which called XERBLA.
*
*  INFO    (input) INTEGER
*          The position of the invalid parameter in the parameter list
*          of the calling routine.
*
* =====================================================================
*
*     .. Executable Statements ..
*
      WRITE( *, FMT = 9999 )SRNAME, INFO
*
      STOP
*
 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
     $      'an illegal value' )
*
*     End of XERBLA
*
      END

c&&&&&&&&inverse****

c inverse routine
      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRI computes the inverse of a matrix using the LU factorization
*  computed by DGETRF.
*
*  This method inverts U and then computes inv(A) by solving the system
*  inv(A)*L = inv(U) for inv(A).
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the factors L and U from the factorization
*          A = P*L*U as computed by DGETRF.
*          On exit, if INFO = 0, the inverse of the original matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*          For optimal performance LWORK >= N*NB, where NB is
*          the optimal blocksize returned by ILAENV.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
*                singular and its inverse could not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
     $                   NBMIN, NN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRI', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular,
*     and the inverse is not computed.
*
      CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
      IF( INFO.GT.0 )
     $   RETURN
*
      NBMIN = 2
      LDWORK = N
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
         IWS = MAX( LDWORK*NB, 1 )
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
         END IF
      ELSE
         IWS = N
      END IF
*
*     Solve the equation inv(A)*L = inv(U) for inv(A).
*
      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
*        Use unblocked code.
*
         DO 20 J = N, 1, -1
*
*           Copy current column of L to WORK and replace with zeros.
*
            DO 10 I = J + 1, N
               WORK( I ) = A( I, J )
               A( I, J ) = ZERO
   10       CONTINUE
*
*           Compute current column of inv(A).
*
            IF( J.LT.N )
     $         CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
   20    CONTINUE
      ELSE
*
*        Use blocked code.
*
         NN = ( ( N-1 ) / NB )*NB + 1
         DO 50 J = NN, 1, -NB
            JB = MIN( NB, N-J+1 )
*
*           Copy current block column of L to WORK and replace with
*           zeros.
*
            DO 40 JJ = J, J + JB - 1
               DO 30 I = JJ + 1, N
                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
                  A( I, JJ ) = ZERO
   30          CONTINUE
   40       CONTINUE
*
*           Compute current block column of inv(A).
*
            IF( J+JB.LE.N )
     $         CALL DGEMM( 'No transpose', 'No transpose', N, JB,
     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
            CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
   50    CONTINUE
      END IF
*
*     Apply column interchanges.
*
      DO 60 J = N - 1, 1, -1
         JP = IPIV( J )
         IF( JP.NE.J )
     $      CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
   60 CONTINUE
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGETRI
*
      END
      SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTI2 computes the inverse of a real upper or lower triangular
*  matrix.
*
*  This is the Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the triangular matrix A.  If UPLO = 'U', the
*          leading n by n upper triangular part of the array A contains
*          the upper triangular matrix, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading n by n lower triangular part of the array A contains
*          the lower triangular matrix, and the strictly upper
*          triangular part of A is not referenced.  If DIAG = 'U', the
*          diagonal elements of A are also not referenced and are
*          assumed to be 1.
*
*          On exit, the (triangular) inverse of the original matrix, in
*          the same storage format.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DSCAL, DTRMV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTI2', -INFO )
         RETURN
      END IF
*
      IF( UPPER ) THEN
*
*        Compute inverse of upper triangular matrix.
*
         DO 10 J = 1, N
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
*
*           Compute elements 1:j-1 of j-th column.
*
            CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
     $                  A( 1, J ), 1 )
            CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
   10    CONTINUE
      ELSE
*
*        Compute inverse of lower triangular matrix.
*
         DO 20 J = N, 1, -1
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
*
*              Compute elements j+1:n of j-th column.
*
               CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
               CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
*
      RETURN
*
*     End of DTRTI2
*
      END
      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTRI computes the inverse of a real upper or lower triangular
*  matrix A.
*
*  This is the Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  A is upper triangular;
*          = 'L':  A is lower triangular.
*
*  DIAG    (input) CHARACTER*1
*          = 'N':  A is non-unit triangular;
*          = 'U':  A is unit triangular.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the triangular matrix A.  If UPLO = 'U', the
*          leading N-by-N upper triangular part of the array A contains
*          the upper triangular matrix, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading N-by-N lower triangular part of the array A contains
*          the lower triangular matrix, and the strictly upper
*          triangular part of A is not referenced.  If DIAG = 'U', the
*          diagonal elements of A are also not referenced and are
*          assumed to be 1.
*          On exit, the (triangular) inverse of the original matrix, in
*          the same storage format.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
*               matrix is singular and its inverse can not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JB, NB, NN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DTRMM, DTRSM, DTRTI2, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRI', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Check for singularity if non-unit.
*
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO )
     $         RETURN
   10    CONTINUE
         INFO = 0
      END IF
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
*        Use unblocked code
*
         CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
      ELSE
*
*        Use blocked code
*
         IF( UPPER ) THEN
*
*           Compute inverse of upper triangular matrix
*
            DO 20 J = 1, N, NB
               JB = MIN( NB, N-J+1 )
*
*              Compute rows 1:j-1 of current block column
*
               CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
               CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
*              Compute inverse of current diagonal block
*
               CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
   20       CONTINUE
         ELSE
*
*           Compute inverse of lower triangular matrix
*
            NN = ( ( N-1 ) / NB )*NB + 1
            DO 30 J = NN, 1, -NB
               JB = MIN( NB, N-J+1 )
               IF( J+JB.LE.N ) THEN
*
*                 Compute rows j+jb:n of current block column
*
                  CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
     $                        A( J+JB, J ), LDA )
                  CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, -ONE, A( J, J ), LDA,
     $                        A( J+JB, J ), LDA )
               END IF
*
*              Compute inverse of current diagonal block
*
               CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
   30       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DTRTRI
*
      END

      LOGICAL          FUNCTION LSAME( CA, CB )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
*  case.
*
*  Arguments
*  =========
*
*  CA      (input) CHARACTER*1
*  CB      (input) CHARACTER*1
*          CA and CB specify the single characters to be compared.
*
* =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
*     ..
*     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA.EQ.CB
      IF( LSAME )
     $   RETURN
*
*     Now test for equivalence if both characters are alphabetic.
*
      ZCODE = ICHAR( 'Z' )
*
*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
*     machines, on which ICHAR returns a value with bit 8 set.
*     ICHAR('A') on Prime machines returns 193 which is the same as
*     ICHAR('A') on an EBCDIC machine.
*
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
*
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
*        ASCII is assumed - ZCODE is the ASCII code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
*        plus 128 of either lower or upper case 'Z'.
*
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
*
*     RETURN
*
*     End of LSAME
*
      END

      SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
     $                   B, LDB )
*     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRSM  solves one of the matrix equations
*
*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
*
*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
*
*     op( A ) = A   or   op( A ) = A'.
*
*  The matrix X is overwritten on B.
*
*  Parameters
*  ==========
*
*  SIDE   - CHARACTER*1.
*           On entry, SIDE specifies whether op( A ) appears on the left
*           or right of X as follows:
*
*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
*
*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
*
*           Unchanged on exit.
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix A is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n'   op( A ) = A.
*
*              TRANSA = 'T' or 't'   op( A ) = A'.
*
*              TRANSA = 'C' or 'c'   op( A ) = A'.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit triangular
*           as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of B. M must be at
*           least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of B.  N must be
*           at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
*           zero then  A is not referenced and  B need not be set before
*           entry.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
*           upper triangular part of the array  A must contain the upper
*           triangular matrix  and the strictly lower triangular part of
*           A is not referenced.
*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
*           lower triangular part of the array  A must contain the lower
*           triangular matrix  and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
*           A  are not referenced either,  but are assumed to be  unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
*           then LDA must be at least max( 1, n ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
*           Before entry,  the leading  m by n part of the array  B must
*           contain  the  right-hand  side  matrix  B,  and  on exit  is
*           overwritten by the solution matrix  X.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
*
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.
     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.
     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
*
*     Start the operations.
*
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*inv( A )*B.
*
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*inv( A' )*B.
*
            IF( UPPER )THEN
               DO 130, J = 1, N
                  DO 120, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     DO 110, K = 1, I - 1
                        TEMP = TEMP - A( K, I )*B( K, J )
  110                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
               DO 160, J = 1, N
                  DO 150, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     DO 140, K = I + 1, M
                        TEMP = TEMP - A( K, I )*B( K, J )
  140                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  150             CONTINUE
  160          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*B*inv( A ).
*
            IF( UPPER )THEN
               DO 210, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 170, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  170                CONTINUE
                  END IF
                  DO 190, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 180, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  180                   CONTINUE
                     END IF
  190             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 200, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
            ELSE
               DO 260, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 220, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  220                CONTINUE
                  END IF
                  DO 240, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 250, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  250                CONTINUE
                  END IF
  260          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*B*inv( A' ).
*
            IF( UPPER )THEN
               DO 310, K = N, 1, -1
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 270, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  270                CONTINUE
                  END IF
                  DO 290, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 280, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  280                   CONTINUE
                     END IF
  290             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 300, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  300                CONTINUE
                  END IF
  310          CONTINUE
            ELSE
               DO 360, K = 1, N
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 320, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  320                CONTINUE
                  END IF
                  DO 340, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 330, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  330                   CONTINUE
                     END IF
  340             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 350, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  350                CONTINUE
                  END IF
  360          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRSM .
*
      END

      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
*     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  DGEMM  performs one of the matrix-matrix operations
*
*     C := alpha*op( A )*op( B ) + beta*C,
*
*  where  op( X ) is one of
*
*     op( X ) = X   or   op( X ) = X',
*
*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n',  op( A ) = A.
*
*              TRANSA = 'T' or 't',  op( A ) = A'.
*
*              TRANSA = 'C' or 'c',  op( A ) = A'.
*
*           Unchanged on exit.
*
*  TRANSB - CHARACTER*1.
*           On entry, TRANSB specifies the form of op( B ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSB = 'N' or 'n',  op( B ) = B.
*
*              TRANSB = 'T' or 't',  op( B ) = B'.
*
*              TRANSB = 'C' or 'c',  op( B ) = B'.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies  the number  of rows  of the  matrix
*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N  specifies the number  of columns of the matrix
*           op( B ) and the number of columns of the matrix C. N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry,  K  specifies  the number of columns of the matrix
*           op( A ) and the number of rows of the matrix op( B ). K must
*           be at least  zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by m  part of the array  A  must contain  the
*           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  n by k  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*           least  max( 1, n ).
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n  matrix
*           ( alpha*op( A )*op( B ) + beta*C ).
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
*     and  columns of  A  and the  number of  rows  of  B  respectively.
*
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     And if  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( NOTB )THEN
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B + beta*C.
*
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B + beta*C
*
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B' + beta*C
*
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B' + beta*C
*
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DGEMM .
*
      END

      subroutine  dswap (n,dx,incx,dy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
c
c       clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n .lt. 1 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      subroutine dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision da,dx(1)
      integer i,incx,m,mp1,n,nincx
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end

      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DGER   performs the rank 1 operation
*
*     A := alpha*x*y' + A,
*
*  where alpha is a scalar, x is an m element vector, y is an n element
*  vector and A is an m by n matrix.
*
*  Parameters
*  ==========
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of the matrix A.
*           M must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( m - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the m
*           element vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y.
*           Unchanged on exit.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry, the leading m by n part of the array A must
*           contain the matrix of coefficients. On exit, A is
*           overwritten by the updated matrix.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGER  ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
     $   RETURN
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
*
      RETURN
*
*     End of DGER  .
*
      END

      SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEMV  performs one of the matrix-vector operations
*
*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
*
*  where alpha and beta are scalars, x and y are vectors and A is an
*  m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
*
*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
*
*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of the matrix A.
*           M must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry, the leading m by n part of the array A must
*           contain the matrix of coefficients.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, m ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of DIMENSION at least
*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*           Before entry, the incremented array X must contain the
*           vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry, BETA specifies the scalar beta. When BETA is
*           supplied as zero then Y need not be set on input.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of DIMENSION at least
*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*           Before entry with BETA non-zero, the incremented array Y
*           must contain the vector y. On exit, Y is overwritten by the
*           updated vector y.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
*     up the start points in  X  and  Y.
*
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
*     First form  y := beta*y.
*
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  y := alpha*A*x + y.
*
         JX = KX
         IF( INCY.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  DO 50, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   50             CONTINUE
               END IF
               JX = JX + INCX
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY   = KY
                  DO 70, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      ELSE
*
*        Form  y := alpha*A'*x + y.
*
         JY = KY
         IF( INCX.EQ.1 )THEN
            DO 100, J = 1, N
               TEMP = ZERO
               DO 90, I = 1, M
                  TEMP = TEMP + A( I, J )*X( I )
   90          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  100       CONTINUE
         ELSE
            DO 120, J = 1, N
               TEMP = ZERO
               IX   = KX
               DO 110, I = 1, M
                  TEMP = TEMP + A( I, J )*X( IX )
                  IX   = IX   + INCX
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DGEMV .
*
      END
      SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DTRMV  performs one of the matrix-vector operations
*
*     x := A*x,   or   x := A'*x,
*
*  where x is an n element vector and  A is an n by n unit, or non-unit,
*  upper or lower triangular matrix.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   x := A*x.
*
*              TRANS = 'T' or 't'   x := A'*x.
*
*              TRANS = 'C' or 'c'   x := A'*x.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           A is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced either, but are assumed to be unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x. On exit, X is overwritten with the
*           tranformed vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  x := A*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*A( I, J )
   10                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*A( J, J )
                  END IF
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, I = 1, J - 1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX + INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*A( I, J )
   50                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*A( J, J )
                  END IF
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, I = N, J + 1, -1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX - INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
*
*        Form  x := A'*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + A( I, J )*X( I )
   90             CONTINUE
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 110, I = J - 1, 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 130, I = J + 1, N
                     TEMP = TEMP + A( I, J )*X( I )
  130             CONTINUE
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 150, I = J + 1, N
                     IX   = IX   + INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  160          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRMV .
*
      END
      SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
     $                   B, LDB )
*     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRMM  performs one of the matrix-matrix operations
*
*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
*
*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
*
*     op( A ) = A   or   op( A ) = A'.
*
*  Parameters
*  ==========
*
*  SIDE   - CHARACTER*1.
*           On entry,  SIDE specifies whether  op( A ) multiplies B from
*           the left or right as follows:
*
*              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
*
*              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
*
*           Unchanged on exit.
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix A is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n'   op( A ) = A.
*
*              TRANSA = 'T' or 't'   op( A ) = A'.
*
*              TRANSA = 'C' or 'c'   op( A ) = A'.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit triangular
*           as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of B. M must be at
*           least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of B.  N must be
*           at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
*           zero then  A is not referenced and  B need not be set before
*           entry.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
*           upper triangular part of the array  A must contain the upper
*           triangular matrix  and the strictly lower triangular part of
*           A is not referenced.
*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
*           lower triangular part of the array  A must contain the lower
*           triangular matrix  and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
*           A  are not referenced either,  but are assumed to be  unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
*           then LDA must be at least max( 1, n ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
*           Before entry,  the leading  m by n part of the array  B must
*           contain the matrix  B,  and  on exit  is overwritten  by the
*           transformed matrix.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
*
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.
     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.
     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
*
*     Start the operations.
*
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*A*B.
*
            IF( UPPER )THEN
               DO 50, J = 1, N
                  DO 40, K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*B( K, J )
                        DO 30, I = 1, K - 1
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   30                   CONTINUE
                        IF( NOUNIT )
     $                     TEMP = TEMP*A( K, K )
                        B( K, J ) = TEMP
                     END IF
   40             CONTINUE
   50          CONTINUE
            ELSE
               DO 80, J = 1, N
                  DO 70 K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP      = ALPHA*B( K, J )
                        B( K, J ) = TEMP
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )*A( K, K )
                        DO 60, I = K + 1, M
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   60                   CONTINUE
                     END IF
   70             CONTINUE
   80          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*A'*B.
*
            IF( UPPER )THEN
               DO 110, J = 1, N
                  DO 100, I = M, 1, -1
                     TEMP = B( I, J )
                     IF( NOUNIT )
     $                  TEMP = TEMP*A( I, I )
                     DO 90, K = 1, I - 1
                        TEMP = TEMP + A( K, I )*B( K, J )
   90                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  100             CONTINUE
  110          CONTINUE
            ELSE
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = B( I, J )
                     IF( NOUNIT )
     $                  TEMP = TEMP*A( I, I )
                     DO 120, K = I + 1, M
                        TEMP = TEMP + A( K, I )*B( K, J )
  120                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  130             CONTINUE
  140          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*B*A.
*
            IF( UPPER )THEN
               DO 180, J = N, 1, -1
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 150, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  150             CONTINUE
                  DO 170, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 160, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  160                   CONTINUE
                     END IF
  170             CONTINUE
  180          CONTINUE
            ELSE
               DO 220, J = 1, N
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 190, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  190             CONTINUE
                  DO 210, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
  220          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*B*A'.
*
            IF( UPPER )THEN
               DO 260, K = 1, N
                  DO 240, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 250, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  250                CONTINUE
                  END IF
  260          CONTINUE
            ELSE
               DO 300, K = N, 1, -1
                  DO 280, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 270, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  270                   CONTINUE
                     END IF
  280             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
  300          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRMM .
*
      END