!=======================================================================!
! Copyright (c) Intel Corporation - All rights reserved.                !
! This file is part of the LIBXSMM library.                             !
!                                                                       !
! For information on the license, see the LICENSE file.                 !
! Further information: https://github.com/hfp/libxsmm/                  !
! SPDX-License-Identifier: BSD-3-Clause                                 !
!=======================================================================!
! Hans Pabst (Intel Corp.), Alexander Heinecke (Intel Corp.)
!=======================================================================!

      PROGRAM smm
        USE :: LIBXSMM, libxsmm_mmcall => libxsmm_dmmcall_abc
        !$ USE omp_lib
        IMPLICIT NONE

        INTEGER, PARAMETER :: T = KIND(0D0)

        REAL(T), ALLOCATABLE :: a(:,:,:), b(:,:,:), c(:,:,:)
        REAL(T), ALLOCATABLE :: sumxsmm(:,:), sumblas(:,:)
        REAL(T), ALLOCATABLE, SAVE :: sumtmp(:,:)
        !DIR$ ATTRIBUTES ALIGN:64 :: a, b, c, sumxsmm, sumtmp
        !$OMP THREADPRIVATE(sumtmp)
        TYPE(LIBXSMM_DMMFUNCTION) :: xmm
        INTEGER(8) :: i, r, s, size0, size1, size2, repetitions, start
        TYPE(LIBXSMM_MATDIFF_INFO) :: diff, max_diff
        INTEGER(LIBXSMM_BLASINT_KIND) :: m, n, k
        DOUBLE PRECISION :: duration, scale
        CHARACTER(32) :: argv
        INTEGER :: argc

        argc = COMMAND_ARGUMENT_COUNT()
        IF (1 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(1, argv)
          READ(argv, "(I32)") m
        ELSE
          m = 23
        END IF
        IF (3 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(3, argv)
          READ(argv, "(I32)") k
        ELSE
          k = m
        END IF
        IF (2 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(2, argv)
          READ(argv, "(I32)") n
        ELSE
          n = k
        END IF
        IF (4 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(4, argv)
          READ(argv, "(I32)") size1
        ELSE
          size1 = 0
        END IF
        IF (5 <= argc) THEN
          CALL GET_COMMAND_ARGUMENT(5, argv)
          READ(argv, "(I32)") size2
        ELSE
          size2 = 0 ! 1 repetition by default
        END IF

        ! Initialize LIBXSMM
        CALL libxsmm_init()

        ! JIT-compile stream(a,b)-kernel
        CALL libxsmm_dispatch(xmm, m, n, k,                             &
     &    alpha=REAL(1,T), beta=REAL(1,T))

        ! workload is about 2 GByte in memory by default
        size0 = (m * k + k * n + m * n) * T ! size of stream(a,b,c)-element in Byte
        size1 = MERGE(2048_8, MERGE(size1, ISHFT(ABS(size0 * size1)     &
     &            + ISHFT(1, 20) - 1, -20), 0.LE.size1), 0.EQ.size1)
        size2 = ISHFT(MERGE(MAX(size2, size1), ISHFT(ABS(size2) * size0 &
     &            + ISHFT(1, 20) - 1, -20), 0.LE.size2), 20) / size0
        s = ISHFT(size1, 20) / size0
        repetitions = size2 / s
        scale = 1D0 / s
        duration = 0

        CALL libxsmm_matdiff_clear(max_diff)
        ALLOCATE(a(m,k,s))
        ALLOCATE(b(k,n,s))

        ! Initialize a, b
        !$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(s, a, b, scale)
        DO i = 1, s
          CALL init(42, a(:,:,i), scale, i - 1)
          CALL init(24, b(:,:,i), scale, i - 1)
        END DO
        !$OMP END PARALLEL DO

        WRITE(*, "(3(A,I0),A,I0,A,I0,A,I0)")                            &
     &    "m=", m, " n=", n, " k=", k, " elements=", UBOUND(a, 3),      &
     &    " size=", size1, " MB repetitions=", repetitions

        ! compute reference solution and warmup BLAS library
        ALLOCATE(sumblas(m,n))
        sumblas(:,:) = 0
        !$OMP PARALLEL REDUCTION(+:sumblas) PRIVATE(i, r)               &
        !$OMP   DEFAULT(NONE) SHARED(m, n, k, a, b, repetitions)
        ALLOCATE(sumtmp(m,n))
        sumtmp(:,:) = 0
        DO r = 1, repetitions
          !$OMP DO
          DO i = LBOUND(a, 3), UBOUND(a, 3)
            ! PGI: cannot deduce generic procedure (libxsmm_blas_gemm)
            CALL libxsmm_blas_dgemm(m=m, n=n, k=k,                      &
     &              a=a(:,:,i), b=b(:,:,i), c=sumtmp)
          END DO
        END DO
        sumblas(:,:) = sumblas(:,:) + sumtmp(:UBOUND(sumblas,1),:)
        ! Deallocate thread-local arrays
        DEALLOCATE(sumtmp)
        !$OMP END PARALLEL

        WRITE(*, "(A)") "Streamed (A,B)... (BLAS)"
        ALLOCATE(sumxsmm(m,n))
        sumxsmm(:,:) = 0
        !$OMP PARALLEL REDUCTION(+:sumxsmm) PRIVATE(i, r, start)        &
        !$OMP   DEFAULT(NONE)                                           &
        !$OMP   SHARED(m, n, k, a, b, duration, repetitions)
        ALLOCATE(sumtmp(m,n))
        sumtmp(:,:) = 0
        !$OMP MASTER
        start = libxsmm_timer_tick()
        !$OMP END MASTER
        !$OMP BARRIER
        DO r = 1, repetitions
          !$OMP DO
          DO i = LBOUND(a, 3), UBOUND(a, 3)
            ! PGI: cannot deduce generic procedure (libxsmm_blas_gemm)
            CALL libxsmm_blas_dgemm(m=m, n=n, k=k,                      &
     &              a=a(:,:,i), b=b(:,:,i), c=sumtmp)
          END DO
        END DO
        !$OMP BARRIER
        !$OMP MASTER
        duration = libxsmm_timer_duration(start, libxsmm_timer_tick())
        !$OMP END MASTER
        sumxsmm(:,:) = sumxsmm(:,:) + sumtmp(:UBOUND(sumxsmm,1),:)
        ! Deallocate thread-local arrays
        DEALLOCATE(sumtmp)
        !$OMP END PARALLEL
        CALL performance(duration, m, n, k, size2, m * k + k * n)

        WRITE(*, "(A)") "Streamed (A,B)... (auto-dispatched)"
        sumxsmm(:,:) = 0
        !$OMP PARALLEL REDUCTION(+:sumxsmm) PRIVATE(i, r, start)        &
        !$OMP   DEFAULT(NONE)                                           &
        !$OMP   SHARED(m, n, k, a, b, duration, repetitions)
        ALLOCATE(sumtmp(m,n))
        sumtmp(:,:) = 0
        !$OMP MASTER
        start = libxsmm_timer_tick()
        !$OMP END MASTER
        !$OMP BARRIER
        DO r = 1, repetitions
          !$OMP DO
          DO i = LBOUND(a, 3), UBOUND(a, 3)
            ! PGI: cannot deduce generic procedure (libxsmm_gemm)
            CALL libxsmm_dgemm(m=m, n=n, k=k,                           &
     &              a=a(:,:,i), b=b(:,:,i), c=sumtmp)
          END DO
        END DO
        !$OMP BARRIER
        !$OMP MASTER
        duration = libxsmm_timer_duration(start, libxsmm_timer_tick())
        !$OMP END MASTER
        sumxsmm(:,:) = sumxsmm(:,:) + sumtmp(:UBOUND(sumxsmm,1),:)
        ! Deallocate thread-local arrays
        DEALLOCATE(sumtmp)
        !$OMP END PARALLEL
        CALL performance(duration, m, n, k, size2, m * k + k * n)
        CALL libxsmm_matdiff(diff, LIBXSMM_DATATYPE_F64, m, n,          &
     &    libxsmm_ptr(sumblas), libxsmm_ptr(sumxsmm))
        WRITE(*, "(1A,A,F10.1)") CHAR(9), "diff:      ", diff%l2_abs
        CALL libxsmm_matdiff_reduce(max_diff, diff)

        IF (libxsmm_available(xmm)) THEN
          sumxsmm(:,:) = 0
          WRITE(*, "(A)") "Streamed (A,B)... (specialized)"
          !$OMP PARALLEL REDUCTION(+:sumxsmm) PRIVATE(i, r, start)
            !DEFAULT(NONE) SHARED(m, n, a, b, duration, repetitions, xmm)
          ALLOCATE(sumtmp(m,n))
          sumtmp(:,:) = 0
          !$OMP MASTER
          start = libxsmm_timer_tick()
          !$OMP END MASTER
          !$OMP BARRIER
          DO r = 1, repetitions
            !$OMP DO
            DO i = LBOUND(a, 3), UBOUND(a, 3)
              CALL libxsmm_mmcall(xmm, a(:,:,i), b(:,:,i), sumtmp)
            END DO
          END DO
          !$OMP BARRIER
          !$OMP MASTER
          duration = libxsmm_timer_duration(start, libxsmm_timer_tick())
          !$OMP END MASTER
          sumxsmm(:,:) = sumxsmm(:,:) + sumtmp(:UBOUND(sumxsmm,1),:)
          ! Deallocate thread-local arrays
          DEALLOCATE(sumtmp)
          !$OMP END PARALLEL
          CALL performance(duration, m, n, k, size2, m * k + k * n)
          CALL libxsmm_matdiff(diff, LIBXSMM_DATATYPE_F64, m, n,        &
     &      libxsmm_ptr(sumblas), libxsmm_ptr(sumxsmm))
          WRITE(*, "(1A,A,F10.1)") CHAR(9), "diff:      ", diff%l2_abs
          CALL libxsmm_matdiff_reduce(max_diff, diff)
        END IF

        WRITE(*, "(A)") "Streamed (A,B,C/Beta=0)... (specialized)"
        ALLOCATE(c(m,n,s))
        start = libxsmm_timer_tick()
        DO r = 1, repetitions
          !$OMP PARALLEL DEFAULT(NONE) SHARED(a, b, c)
          CALL smm_stream_abc_beta0(a, b, c)
          !$OMP END PARALLEL
        END DO
        duration = libxsmm_timer_duration(start, libxsmm_timer_tick())
        CALL performance(duration, m, n, k, size2,                      &
     &    m * k + k * n + m * n * 2) ! 2: assume RFO

        WRITE(*, "(A)") "Streamed (A,B,C/Beta=1)... (specialized)"
        start = libxsmm_timer_tick()
        DO r = 1, repetitions
          !$OMP PARALLEL DEFAULT(NONE) SHARED(a, b, c)
          CALL smm_stream_abc_beta1(a, b, c)
          !$OMP END PARALLEL
        END DO
        duration = libxsmm_timer_duration(start, libxsmm_timer_tick())
        CALL performance(duration, m, n, k, size2,                      &
     &    m * k + k * n + m * n * 2) ! 2: assume RFO

        ! Deallocate global arrays
        DEALLOCATE(a, b, c)
        DEALLOCATE(sumxsmm)
        DEALLOCATE(sumblas)

        ! finalize LIBXSMM
        CALL libxsmm_finalize()

        IF (1.LT.(max_diff%l2_rel)) STOP 1

      CONTAINS
        PURE SUBROUTINE init(seed, matrix, scale, n)
          INTEGER, INTENT(IN) :: seed
          REAL(T), INTENT(OUT) :: matrix(:,:)
          REAL(8), INTENT(IN) :: scale
          INTEGER(8), INTENT(IN), OPTIONAL :: n
          INTEGER(8) :: minval, addval, maxval
          INTEGER :: ld, i, j
          REAL(8) :: val, norm
          ld = UBOUND(matrix, 1) - LBOUND(matrix, 1) + 1
          minval = MERGE(n, 0_8, PRESENT(n)) + seed
          addval = (UBOUND(matrix, 1) - LBOUND(matrix, 1)) * ld         &
     &           + (UBOUND(matrix, 2) - LBOUND(matrix, 2))
          maxval = MAX(ABS(minval), addval)
          norm = MERGE(scale / maxval, scale, 0.NE.maxval)
          DO j = LBOUND(matrix, 2), UBOUND(matrix, 2)
            DO i = LBOUND(matrix, 1),                                   &
     &             LBOUND(matrix, 1) + UBOUND(matrix, 1) - 1
              val = (i - LBOUND(matrix, 1)) * ld                        &
     &            + (j - LBOUND(matrix, 2)) + minval
              matrix(i,j) = norm * (val - 0.5D0 * addval)
            END DO
          END DO
        END SUBROUTINE

        SUBROUTINE disp(matrix, ld, format)
          REAL(T), INTENT(IN) :: matrix(:,:)
          INTEGER, INTENT(IN), OPTIONAL :: ld
          CHARACTER(*), INTENT(IN), OPTIONAL :: format
          CHARACTER(32) :: fmt
          INTEGER :: i0, i1, i, j
          IF (.NOT.PRESENT(format)) THEN
            fmt = "(16F20.0)"
          ELSE
            WRITE(fmt, "('(16',A,')')") format
          END IF
          i0 = LBOUND(matrix, 1)
          i1 = MIN(                                                     &
     &          MERGE(i0 + ld - 1, UBOUND(matrix, 1), PRESENT(ld)),     &
     &          UBOUND(matrix, 1))
          DO i = i0, i1
            DO j = LBOUND(matrix, 2), UBOUND(matrix, 2)
              WRITE(*, fmt, advance='NO') matrix(i,j)
            END DO
            WRITE(*, *)
          END DO
        END SUBROUTINE

        SUBROUTINE performance(duration, m, n, k, s, c)
          INTEGER(LIBXSMM_BLASINT_KIND), INTENT(IN) :: m, n, k, c
          INTEGER(8), INTENT(IN) :: s
          REAL(T), INTENT(IN) :: duration
          IF (0.LT.duration) THEN
            WRITE(*, "(1A,A,F10.1,A)") CHAR(9), "performance:",         &
     &        2D0 * s * m * n * k * 1D-9 / duration, " GFLOPS/s"
            WRITE(*, "(1A,A,F10.1,A)") CHAR(9), "bandwidth:  ",         &
     &        s * c * T / (duration * ISHFT(1_8, 30)), " GB/s"
          END IF
          WRITE(*, "(1A,A,F10.1,A)") CHAR(9), "duration:   ",           &
     &        1D3 * duration, " ms"
        END SUBROUTINE

        SUBROUTINE smm_stream_abc_beta0(a, b, c)
          REAL(T), INTENT(IN)  :: a(:,:,:), b(:,:,:)
          REAL(T), INTENT(OUT) :: c(:,:,:)
          TYPE(LIBXSMM_DMMFUNCTION) :: xmm
          INTEGER(8) :: i
          CALL libxsmm_dispatch(xmm, SIZE(c,1), SIZE(c,2), SIZE(b,1),   &
     &      flags=MERGE(                                                &
     &        LIBXSMM_GEMM_FLAG_ALIGN_C_NTS_HINT_BETA_0,                &
     &        LIBXSMM_GEMM_FLAG_BETA_0,                                 &
     &        libxsmm_aligned(libxsmm_ptr(c(1,1,1)),                    &
     &        SIZE(c,1) * SIZE(c,2) * T)))
          !$OMP DO
          DO i = LBOUND(c, 3, 8), UBOUND(c, 3, 8)
            CALL libxsmm_mmcall(xmm, a(:,:,i), b(:,:,i), c(:,:,i))
          END DO
        END SUBROUTINE

        SUBROUTINE smm_stream_abc_beta1(a, b, c)
          REAL(T), INTENT(IN)    :: a(:,:,:), b(:,:,:)
          REAL(T), INTENT(INOUT) :: c(:,:,:)
          TYPE(LIBXSMM_DMMFUNCTION) :: xmm
          INTEGER(8) :: i
          CALL libxsmm_dispatch(xmm, SIZE(c,1), SIZE(c,2), SIZE(b,1))
          !$OMP DO
          DO i = LBOUND(c, 3, 8), UBOUND(c, 3, 8)
            CALL libxsmm_mmcall(xmm, a(:,:,i), b(:,:,i), c(:,:,i))
          END DO
        END SUBROUTINE
      END PROGRAM


program problem_5b

use aoc_utilities

implicit none

type :: line
    integer :: x1 = 0
    integer :: y1 = 0
    integer :: x2 = 0
    integer :: y2 = 0
end type line

integer :: iunit, n_lines, i, x, y, j, dx, dy
integer,dimension(:,:),allocatable :: map
type(line),dimension(:),allocatable :: lines
character(len=:),allocatable :: line_from_file
logical :: status_ok
type(string),dimension(:),allocatable :: vals
type(string),dimension(:),allocatable :: initial_vals, final_vals
integer :: max_x, max_y
logical :: horizontal, vertical, neither

open(newunit=iunit,file='inputs/day5.txt')

n_lines = number_of_lines_in_file(iunit)

allocate(lines(n_lines))

! first read all the lines:
do i = 1, n_lines
    call read_line_from_file(iunit,line_from_file,status_ok)
    call split(line_from_file,' -> ',vals)
    if (size(vals)/=2) error stop 'invalid line'
    call split(vals(1)%str,',',initial_vals)
    call split(vals(2)%str,',',final_vals)
    if (size(initial_vals)/=2) error stop 'invalid initial_vals'
    if (size(final_vals)/=2) error stop 'invalid final_vals'
    read(initial_vals(1)%str,*) lines(i)%x1
    read(initial_vals(2)%str,*) lines(i)%y1
    read(final_vals(1)%str,*)   lines(i)%x2
    read(final_vals(2)%str,*)   lines(i)%y2
end do
! write(*,*) lines

! now, size the map:
max_x = maxval([lines(:)%x1, lines(:)%x2])
max_y = maxval([lines(:)%y1, lines(:)%y2])
!write(*,*) 'max x,y = ', max_x, max_y

allocate(map(0:max_y, 0:max_x))
map = 0

! now, populate the map with the lines:
do i = 1, n_lines

    ! horizontal, vertical, or diagonal (45 deg) ...

    horizontal = lines(i)%y1 == lines(i)%y2
    vertical   = lines(i)%x1 == lines(i)%x2
    neither = (.not. horizontal) .and. (.not. vertical)

    if (horizontal) then
        dx = sign(1,lines(i)%x2-lines(i)%x1)
        dy = 0
    else if (vertical) then
        dx = 0
        dy = sign(1,lines(i)%y2-lines(i)%y1)
    else
        dx = sign(1,lines(i)%x2-lines(i)%x1)
        dy = sign(1,lines(i)%y2-lines(i)%y1)
    end if

    x = lines(i)%x1
    y = lines(i)%y1
    do
        map(y, x) = map(y, x) + 1
        if (x==lines(i)%x2 .and. y==lines(i)%y2) exit ! done
        x = x + dx
        y = y + dy
    end do

end do

! visualize the board:
do i = 0, ubound(map,1)
    do j = 0, ubound(map,2)
        if (map(i,j)==0) then
            write(998,'(A)',advance='NO') '.'
        else
            write(998,'(I1)',advance='NO') map(i,j)
        end if
    end do
    write(998,*) ''
end do

write(*,*) '5B: number where 2 or more overlap: ', count(map>1)

end program problem_5b


*     DG01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 128 )
*     .. Local Scalars ..
      INTEGER          I, INFO, N
      CHARACTER*1      SCR, WGHT
*     .. Local Arrays ..
      DOUBLE PRECISION A(NMAX), W(NMAX)
*     .. External Subroutines ..
      EXTERNAL         DG01OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, SCR, WGHT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,N )
*        Compute the Hartley transform.
         CALL DG01OD( SCR, WGHT, N, A, W, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) I, A(I)
   10       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' DG01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DG01OD = ',I2)
99997 FORMAT ('   Hartley transform ',//'   i    A(i)',/)
99996 FORMAT (I4,1X,F8.4)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END


      SUBROUTINE MQDPLT
C
C     THIS ROUTINE GENERATES FOUR 6X6 STIFFNESS MATRICES WITH RESPECT
C     TO ONE PIVOT POINT OF A QUADRILATERAL PLATE ELEMENT.
C
C     REF.  FMMS-66   JUNE 23, 1969   TRI.BENDING ELEMENT MASS
C           FMMS-66   JUNE 23, 1969   QUAD. BENDING ELEMENT MASS
C
C     CALLS FROM THIS ROUTINE ARE MADE TO
C           MTRBSC - BASIC BENDING TRI. ROUTINE.
C           TRANSD - SUPPLIES 3X3 TRANSFORMATIONS
C           SMA2B  - INSERTION ROUTINE
C           GMMATD - GENERAL MATRIX MULITPLY AND TRANSPOSE ROUTINE
C           MESAGE - ERROR MESSAGE WRITER
C
C     ALL WRITE STATEMENTS WHICH HAVE BEEN COMMENTED OUT, HAVE BEEN
C     LEFT IN THE PROGRAMMING FOR ANY FUTURE DEBUGGING USE.
C
C     ECPT LISTS AS OF AUGUST 4, 1967
C
C                 DEFINITION                   DEFINITION
C       ECPT      BSC.BEND.TRI.-----TYPE       QUAD.PLT.---------TYPE
C     ========   =============      =======    ===============   =======
C     ECPT( 1) = ELEMENT ID         INTEGER ** ELEMENT           INTEGER
C     ECPT( 2) = GRID PT. A         INTEGER ** GRID PT.A         INTEGER
C     ECPT( 3) = GRID PT. B         INTEGER ** GRID PT.B         INTEGER
C     ECPT( 4) = GRID PT. C         INTEGER ** GRID PT.C         INTEGER
C     ECPT( 5) = THETA              REAL    ** GRID PT.D         INTEGER
C     ECPT( 6) = MAT ID 1           INTEGER ** THETA             REAL
C     ECPT( 7) = I  MOM. OF INERT.  REAL    ** MAT ID 1          INTEGER
C     ECPT( 8) = MAT ID 2           INTEGER ** I  MOM. OF INERT. REAL
C     ECPT( 9) = T2                 REAL    ** MAT ID 2          INTEGER
C     ECPT(10) = NON-STRUCT. MASS   REAL    ** T2                REAL
C     ECPT(11) = Z1                 REAL    ** NON-STRUCT. MASS  REAL
C     ECPT(12) = Z2                 REAL    ** Z1                REAL
C     ECPT(13) = COORD. SYS. ID 1   INTEGER ** Z2                REAL
C     ECPT(14) = X1                 REAL    ** COORD. SYS. ID 1  INTEGER
C     ECPT(15) = Y1                 REAL    ** X1                REAL
C     ECPT(16) = Z1                 REAL    ** Y1                REAL
C     ECPT(17) = COORD. SYS. ID 2   INTEGER ** Z1                REAL
C     ECPT(18) = X2                 REAL    ** COORD. SYS. ID 2  INTEGER
C     ECPT(19) = Y2                 REAL    ** X2                REAL
C     ECPT(20) = Z2                 REAL    ** Y2                REAL
C     ECPT(21) = COORD. SYS. ID 3   INTEGER ** Z2                REAL
C     ECPT(22) = X3                 REAL    ** COORD. SYS. ID 3  INTEGER
C     ECPT(23) = Y3                 REAL    ** X3                REAL
C     ECPT(24) = Z3                 REAL    ** Y3                REAL
C     ECPT(25) = ELEMENT TEMP       REAL    ** Z3                REAL
C     ECPT(26) =                            ** COORD. SYS. ID 4  INTEGER
C     ECPT(27) =                            ** X4                REAL
C     ECPT(28) =                            ** Y4                REAL
C     ECPT(29) =                            ** Z4                REAL
C     ECPT(30) =                            ** ELEMENT TEMP      REAL
C
      INTEGER          SUBSCA,SUBSCB,SUBSCC
      DOUBLE PRECISION MOUT,TITE,DPDUM1,TJTE,DPDUM2,IVECT,D1,JVECT,D2,
     1                 KVECT,A1,MSUM,T,V,VV,XSUBB,XSUBC,YSUBC,PROD9,
     2                 TEMP,TEMP9,TEMP36,U1,U2,H,E,A,REQUIV,R,IIZ,MIZ,
     3                 SIGN,PTMASS,M6X6
      DIMENSION        M(12),NECPT(100),REQUIV(8),VQ1(3),VQ2(3),VQ3(3),
     1                 VQ4(3),A(1),MSUM(36)
      COMMON /CONDAS/  CONSTS(5)
      COMMON /MATIN /  MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALP12,
     1                 T SUB 0,G SUB E,SIGTEN,SIGCOM,SIGSHE,
     2                 G2X211,G2X212,G2X222,SPACE(2)
      COMMON /SMA2IO/  DUM1(10),IFMGG,DUM2(25)
      COMMON /SMA2CL/  DUM3(2),NPVT,DUMCL(7),LINK(10),NOGO
      COMMON /SMA2ET/  ECPT(100)
      COMMON /SMA2DP/  MOUT(36),TITE(9),TJTE(36),TEMP36(36),DPDUM1(27),
     1                 D1(3),D2(3),A1(3),T(9),V(2),VV(2),IIZ,MIZ,SIGN,
     2                 SPDUM(20),M6X6(36),DPDUM2(10),PROD9(9),TEMP9(9),
     3                 XSUBB,XSUBC,YSUBC,E(9),TEMP,SP1(33),KM,NBEGIN,
     4                 JNOT,NPIVOT,THETA,NSUBC,ISING,SUBSCA,SUBSCB,
     5                 SUBSCC,SINANG,COSANG,NPOINT,IVECT(3),JVECT(3),
     6                 KVECT(3),U1,U2,R(2,4),H,PTMASS
      EQUIVALENCE      (CONSTS(4),DEGRA),(NECPT(1),ECPT(1)),
     1                 (R(1,1),REQUIV(1)),(VQ1(1),ECPT(15)),
     2                 (VQ2(1),ECPT(19)),(VQ3(1),ECPT(23)),
     3                 (VQ4(1),ECPT(27)),(A(1),MOUT(1))
      DATA    M     /  2,4,1,  3,1,2,  4,2,3,  1,3,4 /
C
C     DETERMINE PIVOT POINT NUMBER
C
      DO 10 I = 1,4
      IF (NPVT .NE. NECPT(I+1)) GO TO 10
      NPIVOT = I
      GO TO 20
   10 CONTINUE
C
C     FALL THRU ABOVE LOOP IMPLIES ERROR CONDITION
C
      CALL MESAGE (-30,34,ECPT(1))
C
   20 THETA  = ECPT(6)*DEGRA
      SINANG = SIN(THETA)
      COSANG = COS(THETA)
C
      IF (NPIVOT-2) 30,30,40
   30 JNOT = NPIVOT + 2
      GO TO 50
   40 JNOT = NPIVOT - 2
C
C     FORMATION OF THE R-MATRIX CONTAINING COORDINATES OF THE
C     SUB TRIANGLES.  (2X4) FOR QUADRILATERAL PLATE...
C     FORMATION ALSO OF THE I,J, AND K VECTORS USED IN THE E-MATRIX.
C
C     ZERO OUT R-MATRIX
C
   50 DO 60 I = 1,8
   60 REQUIV(I) = 0.0D0
C
C     SHIFT ECPT UP TO MATCH MTRBSC FOR CERTAIN VARIABLES.
C
      DO 80 I = 6,12
   80 ECPT(I) = ECPT(I+1)
C
      DO 90 I = 1,3
      D1(I) = DBLE(VQ3(I)) - DBLE(VQ1(I))
      D2(I) = DBLE(VQ4(I)) - DBLE(VQ2(I))
   90 A1(I) = DBLE(VQ2(I)) - DBLE(VQ1(I))
C
C     NON-NORMALIZED K-VECTOR = D1 CROSS D2
C
      KVECT(1) = D1(2)*D2(3) - D2(2)*D1(3)
      KVECT(2) = D1(3)*D2(1) - D2(3)*D1(1)
      KVECT(3) = D1(1)*D2(2) - D2(1)*D1(2)
C
C     NORMALIZE K-VECTOR
C
      TEMP = DSQRT(KVECT(1)**2 + KVECT(2)**2 + KVECT(3)**2)
      IF (TEMP .EQ. 0.0D0) GO TO 360
      DO 100 I = 1,3
  100 KVECT(I) = KVECT(I)/TEMP
C
C     COMPUTE H = A1 DOT KVECT
C
      H = A1(1)*KVECT(1) + A1(2)*KVECT(2) + A1(3)*KVECT(3)
C
C     WRITE (6,109)
C     WRITE (6,119)
C     WRITE (6,1195) H,(D1(I),D2(I),A1(I),I=1,3)
C
C     I-VECTOR = (A1) - H*(KVECT)  NON-NORMALIZED
C
      DO 110 I = 1,3
  110 IVECT(I) = A1(I) - H*KVECT(I)
C
C     NORMALIZE I-VECTOR
C
      TEMP = DSQRT(IVECT(1)**2 + IVECT(2)**2 + IVECT(3)**2)
      IF (TEMP .EQ. 0.0D0) GO TO 360
      DO 120 I = 1,3
  120 IVECT(I) = IVECT(I)/TEMP
C
C     J-VECTOR = K CROSS I, AND X3 CALCULATION
C
      JVECT(1) = KVECT(2)*IVECT(3) - IVECT(2)*KVECT(3)
      JVECT(2) = KVECT(3)*IVECT(1) - IVECT(3)*KVECT(1)
      JVECT(3) = KVECT(1)*IVECT(2) - IVECT(1)*KVECT(2)
C
C     NORMALIZE J VECTOR TO MAKE SURE
C
      TEMP =  DSQRT(JVECT(1)**2 + JVECT(2)**2 + JVECT(3)**2)
      IF (TEMP .EQ. 0.0D0) GO TO 360
      DO 130 I = 1,3
  130 JVECT(I) = JVECT(I)/TEMP
C
C     X3 GOES INTO R(1,3) = D1 DOT IVECT
C
      R(1,3) = D1(1)*IVECT(1) + D1(2)*IVECT(2) + D1(3)*IVECT(3)
C
C     X2 GOES INTO R(1,2) AND Y3 GOES INTO R(2,3)
C
      R(1,2) = A1(1)*IVECT(1) + A1(2)*IVECT(2) + A1(3)*IVECT(3)
      R(2,3) = D1(1)*JVECT(1) + D1(2)*JVECT(2) + D1(3)*JVECT(3)
C
C     X4 GOES INTO R(1,4) AND Y4 GOES INTO R(2,4)
C
      R(1,4) = D2(1)*IVECT(1) + D2(2)*IVECT(2) + D2(3)*IVECT(3) + R(1,2)
      R(2,4) = D2(1)*JVECT(1) + D2(2)*JVECT(2) + D2(3)*JVECT(3)
C
C     WRITE (6,129) (IVECT(I),I=1,3),(JVECT(I),I=1,3),(KVECT(I),I=1,3),
C    1              ((R(I,J),J=1,4),I=1,2)
C
C     CHECK OF 4 POINTS FOR ANGLE GREATER THAN OR EQUAL TO 180 DEGREES.
C
      IF (R(2,3).LE.0.0D0 .OR. R(2,4).LE.0.0D0) GO TO 140
      TEMP = R(1,2) - (R(1,2)-R(1,3))*R(2,4)/R(2,3)
      IF (R(1,4) .GE. TEMP) GO TO 140
      TEMP = R(2,3)*R(1,4)/R(2,4)
      IF (R(1,3) .GT. TEMP) GO TO 150
  140 CALL MESAGE (30,35,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C     AT 140 THE COORDINATES OF THE PLATE IN THE ELEMENT
C     SYSTEM ARE STORED IN THE R-MATRIX WHERE THE COLUMN DENOTES THE
C     POINT AND THE ROW DENOTES THE X OR Y COORDINATE FOR ROW 1 OR
C     ROW 2 RESPECTIVELY.
C
C     SET UP THE M-MATRIX FOR MAPPING TRIANGLES, IN DATA STATEMENT.
C
C     COMPUTE SUB-TRIANGLE COORDINATES
C
C     ZERO OUT MSUM MATRICES
C
  150 DO 160 I = 1,36
  160 MSUM(I) = 0.0D0
      PTMASS  = 0.0D0
      ELTEMP  = ECPT(30)
C
      DO 220 J = 1,4
      IF (J .EQ. JNOT) GO TO 220
      KM = 3*J - 3
      SUBSCA = M(KM+1)
      SUBSCB = M(KM+2)
      SUBSCC = M(KM+3)
C
      DO 170 I = 1,2
      V(I)  = R(I,SUBSCB) - R(I,SUBSCA)
  170 VV(I) = R(I,SUBSCC) - R(I,SUBSCA)
      XSUBB = DSQRT(V(1)**2 + V(2)**2)
      U1    = V(1)/XSUBB
      U2    = V(2)/XSUBB
      XSUBC = U1*VV(1) + U2*VV(2)
      YSUBC = U1*VV(2) - U2*VV(1)
C
      SINTH = SINANG*U1 - COSANG*U2
      COSTH = COSANG*U1 + SINANG*U2
      IF (ABS(SINTH) .LT. 1.0E-06) SINTH = 0.0E0
C
C     AT THIS POINT, XSUBB, XSUBC, YSUBC ARE AT HAND FOR
C     TRIANGLE -J-
C
C     WRITE(6,139) XSUBB,XSUBC,YSUBC
C
      CALL MTRBSC
C                         U
C     NOW HAVE AT HAND  M    I,J, =1,2,3.   9-3X3 MATRICES STORED AT
C                        IJ                 A(1) THROUGH A(81).
C
C     MAP THE 3 3X3-S FOR THE PIVOT ROW INTO THE SUMMATION ARRAYS...
C
C     SET UP OF T-MATRIX
C
      T(1) = 1.0D0
      T(2) = 0.0D0
      T(3) = 0.0D0
      T(4) = 0.0D0
      T(5) = U1
      T(6) = U2
      T(7) = 0.0D0
      T(8) =-U2
      T(9) = U1
C
C
C     FIND WHICH POINT OF THE SUBTRIANGLE IS ALSO THE PIVOT OF THE
C     QUADRILATERAL
C
      DO 180 I = 1,3
      NPOINT = KM + I
      IF (M(NPOINT) .NE. NPIVOT) GO TO 180
      NBEGIN = 27*I - 27
      GO TO 190
  180 CONTINUE
C
  190 DO 210 I = 1,3
      NPOINT = NBEGIN + 9*I - 8
      CALL GMMATD (T,3,3,1, A(NPOINT),3,3,0, TEMP9)
      CALL GMMATD (TEMP9,3,3,0, T,3,3,0, PROD9)
C
C     ADD THIS PRODUCT IN NOW.
C
      NPOINT = KM + I
      NPOINT = 9*M(NPOINT) - 9
      DO 200 K = 1,9
      NPOINT = NPOINT + 1
  200 MSUM(NPOINT) = MSUM(NPOINT) + PROD9(K)/2.0D0
C
C
  210 CONTINUE
C
      PTMASS = PTMASS + DBLE(ECPT(10))/4.0D0 * XSUBB*YSUBC
  220 CONTINUE
      PTMASS = PTMASS/3.0D0
C
      DO 225 I = 1,36
  225 TJTE(I) = 0.0D0
C
C     FILL E-MATRIX
C
      DO 230 I = 1,9
  230 E(I) = 0.0D0
      DO 235 I = 1,3
      NPOINT = 3*I - 2
      E(NPOINT  ) = IVECT(I)
      E(NPOINT+1) = JVECT(I)
  235 E(NPOINT+2) = KVECT(I)
C
C
C              T
C     FORM   T   E      STORE IN TITE-MATRIX (6X3)
C             I
C
      IF (NECPT(4*NPIVOT+10) .EQ. 0) GO TO 240
      CALL TRANSD (NECPT(4*NPIVOT+10),T)
      CALL GMMATD (T,3,3,1, E(1),3,3,0, TITE(1))
C
C
      GO TO 260
C
  240 DO 250 K = 1,9
  250 TITE(K) = E(K)
C
C
C     TRANSFORMATIONS AND INSERTION
C
  260 DO 350 J = 1,4
      NBEGIN = 9*J - 9
      DO 265 I = 1,36
  265 M6X6(I) = 0.0D0
      DO 270 I = 1,3
      NPOINT = NBEGIN + I
      M6X6(I+14) = MSUM(NPOINT  )
      M6X6(I+20) = MSUM(NPOINT+3)
  270 M6X6(I+26) = MSUM(NPOINT+6)
C
C
      IF (NPIVOT .NE. J) GO TO 290
C
      SIGN     = (-1)**J
      TEMP     = PTMASS*H
      MIZ      = TEMP/2.0D0*SIGN
      IIZ      = TEMP*H/2.0D0
      M6X6( 1) = PTMASS
      M6X6( 5) = MIZ
      M6X6( 8) = M6X6(1)
      M6X6(10) =-MIZ
      M6X6(20) = M6X6(10)
      M6X6(22) = M6X6(22) + IIZ
      M6X6(25) = MIZ
      M6X6(29) = M6X6(29) + IIZ
C
C
  290 IF (NECPT(4*J+10) .EQ. 0) GO TO 320
      CALL TRANSD (NECPT(4*J+10),T)
      CALL GMMATD (E(1),3,3,1, T(1),3,3,0, TJTE(1))
      DO 300 I = 1,3
      NPOINT = I + 21
      TJTE(NPOINT   ) = TJTE(I  )
      TJTE(NPOINT+ 6) = TJTE(I+3)
  300 TJTE(NPOINT+12) = TJTE(I+6)
      DO 310 I = 1,3
      NPOINT = I + 21
      TJTE(I   ) = TJTE(NPOINT   )
      TJTE(I+ 6) = TJTE(NPOINT+ 6)
      TJTE(I+12) = TJTE(NPOINT+12)
  310 TJTE(I+ 3) = 0.0D0
C
      GO TO 340
C
  320 DO 330 I = 1,3
      NPOINT = 6*I - 5
      NPT    = NPOINT + 21
      TJTE(NPOINT  ) = E(I  )
      TJTE(NPOINT+1) = E(I+3)
      TJTE(NPOINT+2) = E(I+6)
      TJTE(NPT     ) = E(I  )
      TJTE(NPT   +1) = E(I+3)
  330 TJTE(NPT   +2) = E(I+6)
C
C
  340 CALL GMMATD (M6X6(1),6,6,0, TJTE(1),6,6,0, TEMP36(1))
      CALL GMMATD (TITE(1),3,3,0, TEMP36( 1),3,6,0, MOUT( 1))
      CALL GMMATD (TITE(1),3,3,0, TEMP36(19),3,6,0, MOUT(19))
C
C
      CALL SMA2B (MOUT(1),NECPT(J+1),-1,IFMGG,0.0D0)
C
  350 CONTINUE
      RETURN
C
C
  360 CALL MESAGE (30,26,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
      END


std_atm_table_len = 201
allocate(std_atm_hgt_col(std_atm_table_len), std_atm_pres_col(std_atm_table_len))

std_atm_hgt_col(1)   = 1000.0_r8  ;  std_atm_pres_col(1)   = 7.518E-09_r8
std_atm_hgt_col(2)   =  995.0_r8  ;  std_atm_pres_col(2)   = 7.651E-09_r8
std_atm_hgt_col(3)   =  990.0_r8  ;  std_atm_pres_col(3)   = 7.790E-09_r8
std_atm_hgt_col(4)   =  985.0_r8  ;  std_atm_pres_col(4)   = 7.931E-09_r8
std_atm_hgt_col(5)   =  980.0_r8  ;  std_atm_pres_col(5)   = 8.075E-09_r8
std_atm_hgt_col(6)   =  975.0_r8  ;  std_atm_pres_col(6)   = 8.222E-09_r8
std_atm_hgt_col(7)   =  970.0_r8  ;  std_atm_pres_col(7)   = 8.371E-09_r8
std_atm_hgt_col(8)   =  965.0_r8  ;  std_atm_pres_col(8)   = 8.524E-09_r8
std_atm_hgt_col(9)   =  960.0_r8  ;  std_atm_pres_col(9)   = 8.680E-09_r8
std_atm_hgt_col(10)  =  955.0_r8  ;  std_atm_pres_col(10)  = 8.839E-09_r8
std_atm_hgt_col(11)  =  950.0_r8  ;  std_atm_pres_col(11)  = 9.001E-09_r8
std_atm_hgt_col(12)  =  945.0_r8  ;  std_atm_pres_col(12)  = 9.168E-09_r8
std_atm_hgt_col(13)  =  940.0_r8  ;  std_atm_pres_col(13)  = 9.338E-09_r8
std_atm_hgt_col(14)  =  935.0_r8  ;  std_atm_pres_col(14)  = 9.513E-09_r8
std_atm_hgt_col(15)  =  930.0_r8  ;  std_atm_pres_col(15)  = 9.692E-09_r8
std_atm_hgt_col(16)  =  925.0_r8  ;  std_atm_pres_col(16)  = 9.875E-09_r8
std_atm_hgt_col(17)  =  920.0_r8  ;  std_atm_pres_col(17)  = 1.006E-08_r8
std_atm_hgt_col(18)  =  915.0_r8  ;  std_atm_pres_col(18)  = 1.026E-08_r8
std_atm_hgt_col(19)  =  910.0_r8  ;  std_atm_pres_col(19)  = 1.046E-08_r8
std_atm_hgt_col(20)  =  905.0_r8  ;  std_atm_pres_col(20)  = 1.066E-08_r8
std_atm_hgt_col(21)  =  900.0_r8  ;  std_atm_pres_col(21)  = 1.087E-08_r8
std_atm_hgt_col(22)  =  895.0_r8  ;  std_atm_pres_col(22)  = 1.109E-08_r8
std_atm_hgt_col(23)  =  890.0_r8  ;  std_atm_pres_col(23)  = 1.132E-08_r8
std_atm_hgt_col(24)  =  885.0_r8  ;  std_atm_pres_col(24)  = 1.155E-08_r8
std_atm_hgt_col(25)  =  880.0_r8  ;  std_atm_pres_col(25)  = 1.179E-08_r8
std_atm_hgt_col(26)  =  875.0_r8  ;  std_atm_pres_col(26)  = 1.203E-08_r8
std_atm_hgt_col(27)  =  870.0_r8  ;  std_atm_pres_col(27)  = 1.229E-08_r8
std_atm_hgt_col(28)  =  865.0_r8  ;  std_atm_pres_col(28)  = 1.255E-08_r8
std_atm_hgt_col(29)  =  860.0_r8  ;  std_atm_pres_col(29)  = 1.283E-08_r8
std_atm_hgt_col(30)  =  855.0_r8  ;  std_atm_pres_col(30)  = 1.311E-08_r8
std_atm_hgt_col(31)  =  850.0_r8  ;  std_atm_pres_col(31)  = 1.340E-08_r8
std_atm_hgt_col(32)  =  845.0_r8  ;  std_atm_pres_col(32)  = 1.371E-08_r8
std_atm_hgt_col(33)  =  840.0_r8  ;  std_atm_pres_col(33)  = 1.402E-08_r8
std_atm_hgt_col(34)  =  835.0_r8  ;  std_atm_pres_col(34)  = 1.435E-08_r8
std_atm_hgt_col(35)  =  830.0_r8  ;  std_atm_pres_col(35)  = 1.469E-08_r8
std_atm_hgt_col(36)  =  825.0_r8  ;  std_atm_pres_col(36)  = 1.504E-08_r8
std_atm_hgt_col(37)  =  820.0_r8  ;  std_atm_pres_col(37)  = 1.541E-08_r8
std_atm_hgt_col(38)  =  815.0_r8  ;  std_atm_pres_col(38)  = 1.579E-08_r8
std_atm_hgt_col(39)  =  810.0_r8  ;  std_atm_pres_col(39)  = 1.619E-08_r8
std_atm_hgt_col(40)  =  805.0_r8  ;  std_atm_pres_col(40)  = 1.660E-08_r8
std_atm_hgt_col(41)  =  800.0_r8  ;  std_atm_pres_col(41)  = 1.704E-08_r8
std_atm_hgt_col(42)  =  795.0_r8  ;  std_atm_pres_col(42)  = 1.749E-08_r8
std_atm_hgt_col(43)  =  790.0_r8  ;  std_atm_pres_col(43)  = 1.795E-08_r8
std_atm_hgt_col(44)  =  785.0_r8  ;  std_atm_pres_col(44)  = 1.844E-08_r8
std_atm_hgt_col(45)  =  780.0_r8  ;  std_atm_pres_col(45)  = 1.896E-08_r8
std_atm_hgt_col(46)  =  775.0_r8  ;  std_atm_pres_col(46)  = 1.949E-08_r8
std_atm_hgt_col(47)  =  770.0_r8  ;  std_atm_pres_col(47)  = 2.006E-08_r8
std_atm_hgt_col(48)  =  765.0_r8  ;  std_atm_pres_col(48)  = 2.064E-08_r8
std_atm_hgt_col(49)  =  760.0_r8  ;  std_atm_pres_col(49)  = 2.126E-08_r8
std_atm_hgt_col(50)  =  755.0_r8  ;  std_atm_pres_col(50)  = 2.191E-08_r8
std_atm_hgt_col(51)  =  750.0_r8  ;  std_atm_pres_col(51)  = 2.260E-08_r8
std_atm_hgt_col(52)  =  745.0_r8  ;  std_atm_pres_col(52)  = 2.331E-08_r8
std_atm_hgt_col(53)  =  740.0_r8  ;  std_atm_pres_col(53)  = 2.407E-08_r8
std_atm_hgt_col(54)  =  735.0_r8  ;  std_atm_pres_col(54)  = 2.487E-08_r8
std_atm_hgt_col(55)  =  730.0_r8  ;  std_atm_pres_col(55)  = 2.571E-08_r8
std_atm_hgt_col(56)  =  725.0_r8  ;  std_atm_pres_col(56)  = 2.660E-08_r8
std_atm_hgt_col(57)  =  720.0_r8  ;  std_atm_pres_col(57)  = 2.755E-08_r8
std_atm_hgt_col(58)  =  715.0_r8  ;  std_atm_pres_col(58)  = 2.854E-08_r8
std_atm_hgt_col(59)  =  710.0_r8  ;  std_atm_pres_col(59)  = 2.960E-08_r8
std_atm_hgt_col(60)  =  705.0_r8  ;  std_atm_pres_col(60)  = 3.072E-08_r8
std_atm_hgt_col(61)  =  700.0_r8  ;  std_atm_pres_col(61)  = 3.191E-08_r8
std_atm_hgt_col(62)  =  695.0_r8  ;  std_atm_pres_col(62)  = 3.317E-08_r8
std_atm_hgt_col(63)  =  690.0_r8  ;  std_atm_pres_col(63)  = 3.451E-08_r8
std_atm_hgt_col(64)  =  685.0_r8  ;  std_atm_pres_col(64)  = 3.594E-08_r8
std_atm_hgt_col(65)  =  680.0_r8  ;  std_atm_pres_col(65)  = 3.746E-08_r8
std_atm_hgt_col(66)  =  675.0_r8  ;  std_atm_pres_col(66)  = 3.908E-08_r8
std_atm_hgt_col(67)  =  670.0_r8  ;  std_atm_pres_col(67)  = 4.080E-08_r8
std_atm_hgt_col(68)  =  665.0_r8  ;  std_atm_pres_col(68)  = 4.264E-08_r8
std_atm_hgt_col(69)  =  660.0_r8  ;  std_atm_pres_col(69)  = 4.459E-08_r8
std_atm_hgt_col(70)  =  655.0_r8  ;  std_atm_pres_col(70)  = 4.668E-08_r8
std_atm_hgt_col(71)  =  650.0_r8  ;  std_atm_pres_col(71)  = 4.892E-08_r8
std_atm_hgt_col(72)  =  645.0_r8  ;  std_atm_pres_col(72)  = 5.130E-08_r8
std_atm_hgt_col(73)  =  640.0_r8  ;  std_atm_pres_col(73)  = 5.385E-08_r8
std_atm_hgt_col(74)  =  635.0_r8  ;  std_atm_pres_col(74)  = 5.659E-08_r8
std_atm_hgt_col(75)  =  630.0_r8  ;  std_atm_pres_col(75)  = 5.951E-08_r8
std_atm_hgt_col(76)  =  625.0_r8  ;  std_atm_pres_col(76)  = 6.264E-08_r8
std_atm_hgt_col(77)  =  620.0_r8  ;  std_atm_pres_col(77)  = 6.600E-08_r8
std_atm_hgt_col(78)  =  615.0_r8  ;  std_atm_pres_col(78)  = 6.961E-08_r8
std_atm_hgt_col(79)  =  610.0_r8  ;  std_atm_pres_col(79)  = 7.349E-08_r8
std_atm_hgt_col(80)  =  605.0_r8  ;  std_atm_pres_col(80)  = 7.765E-08_r8
std_atm_hgt_col(81)  =  600.0_r8  ;  std_atm_pres_col(81)  = 8.213E-08_r8
std_atm_hgt_col(82)  =  595.0_r8  ;  std_atm_pres_col(82)  = 8.695E-08_r8
std_atm_hgt_col(83)  =  590.0_r8  ;  std_atm_pres_col(83)  = 9.214E-08_r8
std_atm_hgt_col(84)  =  585.0_r8  ;  std_atm_pres_col(84)  = 9.774E-08_r8
std_atm_hgt_col(85)  =  580.0_r8  ;  std_atm_pres_col(85)  = 1.038E-07_r8
std_atm_hgt_col(86)  =  575.0_r8  ;  std_atm_pres_col(86)  = 1.103E-07_r8
std_atm_hgt_col(87)  =  570.0_r8  ;  std_atm_pres_col(87)  = 1.173E-07_r8
std_atm_hgt_col(88)  =  565.0_r8  ;  std_atm_pres_col(88)  = 1.249E-07_r8
std_atm_hgt_col(89)  =  560.0_r8  ;  std_atm_pres_col(89)  = 1.330E-07_r8
std_atm_hgt_col(90)  =  555.0_r8  ;  std_atm_pres_col(90)  = 1.418E-07_r8
std_atm_hgt_col(91)  =  550.0_r8  ;  std_atm_pres_col(91)  = 1.514E-07_r8
std_atm_hgt_col(92)  =  545.0_r8  ;  std_atm_pres_col(92)  = 1.617E-07_r8
std_atm_hgt_col(93)  =  540.0_r8  ;  std_atm_pres_col(93)  = 1.728E-07_r8
std_atm_hgt_col(94)  =  535.0_r8  ;  std_atm_pres_col(94)  = 1.849E-07_r8
std_atm_hgt_col(95)  =  530.0_r8  ;  std_atm_pres_col(95)  = 1.979E-07_r8
std_atm_hgt_col(96)  =  525.0_r8  ;  std_atm_pres_col(96)  = 2.120E-07_r8
std_atm_hgt_col(97)  =  520.0_r8  ;  std_atm_pres_col(97)  = 2.273E-07_r8
std_atm_hgt_col(98)  =  515.0_r8  ;  std_atm_pres_col(98)  = 2.439E-07_r8
std_atm_hgt_col(99)  =  510.0_r8  ;  std_atm_pres_col(99)  = 2.618E-07_r8
std_atm_hgt_col(100) =  505.0_r8  ;  std_atm_pres_col(100) = 2.813E-07_r8
std_atm_hgt_col(101) =  500.0_r8  ;  std_atm_pres_col(101) = 3.024E-07_r8
std_atm_hgt_col(102) =  495.0_r8  ;  std_atm_pres_col(102) = 3.252E-07_r8
std_atm_hgt_col(103) =  490.0_r8  ;  std_atm_pres_col(103) = 3.501E-07_r8
std_atm_hgt_col(104) =  485.0_r8  ;  std_atm_pres_col(104) = 3.770E-07_r8
std_atm_hgt_col(105) =  480.0_r8  ;  std_atm_pres_col(105) = 4.063E-07_r8
std_atm_hgt_col(106) =  475.0_r8  ;  std_atm_pres_col(106) = 4.382E-07_r8
std_atm_hgt_col(107) =  470.0_r8  ;  std_atm_pres_col(107) = 4.728E-07_r8
std_atm_hgt_col(108) =  465.0_r8  ;  std_atm_pres_col(108) = 5.104E-07_r8
std_atm_hgt_col(109) =  460.0_r8  ;  std_atm_pres_col(109) = 5.514E-07_r8
std_atm_hgt_col(110) =  455.0_r8  ;  std_atm_pres_col(110) = 5.960E-07_r8
std_atm_hgt_col(111) =  450.0_r8  ;  std_atm_pres_col(111) = 6.445E-07_r8
std_atm_hgt_col(112) =  445.0_r8  ;  std_atm_pres_col(112) = 6.974E-07_r8
std_atm_hgt_col(113) =  440.0_r8  ;  std_atm_pres_col(113) = 7.550E-07_r8
std_atm_hgt_col(114) =  435.0_r8  ;  std_atm_pres_col(114) = 8.179E-07_r8
std_atm_hgt_col(115) =  430.0_r8  ;  std_atm_pres_col(115) = 8.864E-07_r8
std_atm_hgt_col(116) =  425.0_r8  ;  std_atm_pres_col(116) = 9.612E-07_r8
std_atm_hgt_col(117) =  420.0_r8  ;  std_atm_pres_col(117) = 1.043E-06_r8
std_atm_hgt_col(118) =  415.0_r8  ;  std_atm_pres_col(118) = 1.132E-06_r8
std_atm_hgt_col(119) =  410.0_r8  ;  std_atm_pres_col(119) = 1.229E-06_r8
std_atm_hgt_col(120) =  405.0_r8  ;  std_atm_pres_col(120) = 1.336E-06_r8
std_atm_hgt_col(121) =  400.0_r8  ;  std_atm_pres_col(121) = 1.452E-06_r8
std_atm_hgt_col(122) =  395.0_r8  ;  std_atm_pres_col(122) = 1.579E-06_r8
std_atm_hgt_col(123) =  390.0_r8  ;  std_atm_pres_col(123) = 1.718E-06_r8
std_atm_hgt_col(124) =  385.0_r8  ;  std_atm_pres_col(124) = 1.870E-06_r8
std_atm_hgt_col(125) =  380.0_r8  ;  std_atm_pres_col(125) = 2.037E-06_r8
std_atm_hgt_col(126) =  375.0_r8  ;  std_atm_pres_col(126) = 2.220E-06_r8
std_atm_hgt_col(127) =  370.0_r8  ;  std_atm_pres_col(127) = 2.421E-06_r8
std_atm_hgt_col(128) =  365.0_r8  ;  std_atm_pres_col(128) = 2.641E-06_r8
std_atm_hgt_col(129) =  360.0_r8  ;  std_atm_pres_col(129) = 2.884E-06_r8
std_atm_hgt_col(130) =  355.0_r8  ;  std_atm_pres_col(130) = 3.151E-06_r8
std_atm_hgt_col(131) =  350.0_r8  ;  std_atm_pres_col(131) = 3.445E-06_r8
std_atm_hgt_col(132) =  345.0_r8  ;  std_atm_pres_col(132) = 3.769E-06_r8
std_atm_hgt_col(133) =  340.0_r8  ;  std_atm_pres_col(133) = 4.126E-06_r8
std_atm_hgt_col(134) =  335.0_r8  ;  std_atm_pres_col(134) = 4.521E-06_r8
std_atm_hgt_col(135) =  330.0_r8  ;  std_atm_pres_col(135) = 4.957E-06_r8
std_atm_hgt_col(136) =  325.0_r8  ;  std_atm_pres_col(136) = 5.440E-06_r8
std_atm_hgt_col(137) =  320.0_r8  ;  std_atm_pres_col(137) = 5.975E-06_r8
std_atm_hgt_col(138) =  315.0_r8  ;  std_atm_pres_col(138) = 6.568E-06_r8
std_atm_hgt_col(139) =  310.0_r8  ;  std_atm_pres_col(139) = 7.226E-06_r8
std_atm_hgt_col(140) =  305.0_r8  ;  std_atm_pres_col(140) = 7.957E-06_r8
std_atm_hgt_col(141) =  300.0_r8  ;  std_atm_pres_col(141) = 8.770E-06_r8
std_atm_hgt_col(142) =  295.0_r8  ;  std_atm_pres_col(142) = 9.676E-06_r8
std_atm_hgt_col(143) =  290.0_r8  ;  std_atm_pres_col(143) = 1.069E-05_r8
std_atm_hgt_col(144) =  285.0_r8  ;  std_atm_pres_col(144) = 1.181E-05_r8
std_atm_hgt_col(145) =  280.0_r8  ;  std_atm_pres_col(145) = 1.308E-05_r8
std_atm_hgt_col(146) =  275.0_r8  ;  std_atm_pres_col(146) = 1.449E-05_r8
std_atm_hgt_col(147) =  270.0_r8  ;  std_atm_pres_col(147) = 1.608E-05_r8
std_atm_hgt_col(148) =  265.0_r8  ;  std_atm_pres_col(148) = 1.787E-05_r8
std_atm_hgt_col(149) =  260.0_r8  ;  std_atm_pres_col(149) = 1.989E-05_r8
std_atm_hgt_col(150) =  255.0_r8  ;  std_atm_pres_col(150) = 2.218E-05_r8
std_atm_hgt_col(151) =  250.0_r8  ;  std_atm_pres_col(151) = 2.476E-05_r8
std_atm_hgt_col(152) =  245.0_r8  ;  std_atm_pres_col(152) = 2.770E-05_r8
std_atm_hgt_col(153) =  240.0_r8  ;  std_atm_pres_col(153) = 3.105E-05_r8
std_atm_hgt_col(154) =  235.0_r8  ;  std_atm_pres_col(154) = 3.488E-05_r8
std_atm_hgt_col(155) =  230.0_r8  ;  std_atm_pres_col(155) = 3.927E-05_r8
std_atm_hgt_col(156) =  225.0_r8  ;  std_atm_pres_col(156) = 4.432E-05_r8
std_atm_hgt_col(157) =  220.0_r8  ;  std_atm_pres_col(157) = 5.015E-05_r8
std_atm_hgt_col(158) =  215.0_r8  ;  std_atm_pres_col(158) = 5.690E-05_r8
std_atm_hgt_col(159) =  210.0_r8  ;  std_atm_pres_col(159) = 6.476E-05_r8
std_atm_hgt_col(160) =  205.0_r8  ;  std_atm_pres_col(160) = 7.394E-05_r8
std_atm_hgt_col(161) =  200.0_r8  ;  std_atm_pres_col(161) = 8.474E-05_r8
std_atm_hgt_col(162) =  195.0_r8  ;  std_atm_pres_col(162) = 9.749E-05_r8
std_atm_hgt_col(163) =  190.0_r8  ;  std_atm_pres_col(163) = 1.127E-04_r8
std_atm_hgt_col(164) =  185.0_r8  ;  std_atm_pres_col(164) = 1.308E-04_r8
std_atm_hgt_col(165) =  180.0_r8  ;  std_atm_pres_col(165) = 1.527E-04_r8
std_atm_hgt_col(166) =  175.0_r8  ;  std_atm_pres_col(166) = 1.794E-04_r8
std_atm_hgt_col(167) =  170.0_r8  ;  std_atm_pres_col(167) = 2.121E-04_r8
std_atm_hgt_col(168) =  165.0_r8  ;  std_atm_pres_col(168) = 2.528E-04_r8
std_atm_hgt_col(169) =  160.0_r8  ;  std_atm_pres_col(169) = 3.039E-04_r8
std_atm_hgt_col(170) =  155.0_r8  ;  std_atm_pres_col(170) = 3.693E-04_r8
std_atm_hgt_col(171) =  150.0_r8  ;  std_atm_pres_col(171) = 4.542E-04_r8
std_atm_hgt_col(172) =  145.0_r8  ;  std_atm_pres_col(172) = 5.669E-04_r8
std_atm_hgt_col(173) =  140.0_r8  ;  std_atm_pres_col(173) = 7.203E-04_r8
std_atm_hgt_col(174) =  135.0_r8  ;  std_atm_pres_col(174) = 9.357E-04_r8
std_atm_hgt_col(175) =  130.0_r8  ;  std_atm_pres_col(175) = 1.250E-03_r8
std_atm_hgt_col(176) =  125.0_r8  ;  std_atm_pres_col(176) = 1.736E-03_r8
std_atm_hgt_col(177) =  120.0_r8  ;  std_atm_pres_col(177) = 2.537E-03_r8
std_atm_hgt_col(178) =  115.0_r8  ;  std_atm_pres_col(178) = 4.004E-03_r8
std_atm_hgt_col(179) =  110.0_r8  ;  std_atm_pres_col(179) = 7.149E-03_r8
std_atm_hgt_col(180) =  105.0_r8  ;  std_atm_pres_col(180) = 1.442E-02_r8
std_atm_hgt_col(181) =  100.0_r8  ;  std_atm_pres_col(181) = 3.201E-02_r8
std_atm_hgt_col(182) =   95.0_r8  ;  std_atm_pres_col(182) = 7.577E-02_r8
std_atm_hgt_col(183) =   90.0_r8  ;  std_atm_pres_col(183) = 1.844E-01_r8
std_atm_hgt_col(184) =   85.0_r8  ;  std_atm_pres_col(184) = 4.457E-01_r8
std_atm_hgt_col(185) =   80.0_r8  ;  std_atm_pres_col(185) = 1.052E+00_r8
std_atm_hgt_col(186) =   75.0_r8  ;  std_atm_pres_col(186) = 2.388E+00_r8
std_atm_hgt_col(187) =   70.0_r8  ;  std_atm_pres_col(187) = 5.221E+00_r8
std_atm_hgt_col(188) =   65.0_r8  ;  std_atm_pres_col(188) = 1.093E+01_r8
std_atm_hgt_col(189) =   60.0_r8  ;  std_atm_pres_col(189) = 2.196E+01_r8
std_atm_hgt_col(190) =   55.0_r8  ;  std_atm_pres_col(190) = 4.253E+01_r8
std_atm_hgt_col(191) =   50.0_r8  ;  std_atm_pres_col(191) = 7.978E+01_r8
std_atm_hgt_col(192) =   45.0_r8  ;  std_atm_pres_col(192) = 1.491E+02_r8
std_atm_hgt_col(193) =   40.0_r8  ;  std_atm_pres_col(193) = 2.871E+02_r8
std_atm_hgt_col(194) =   35.0_r8  ;  std_atm_pres_col(194) = 5.746E+02_r8
std_atm_hgt_col(195) =   30.0_r8  ;  std_atm_pres_col(195) = 1.197E+03_r8
std_atm_hgt_col(196) =   25.0_r8  ;  std_atm_pres_col(196) = 2.549E+03_r8
std_atm_hgt_col(197) =   20.0_r8  ;  std_atm_pres_col(197) = 5.529E+03_r8
std_atm_hgt_col(198) =   15.0_r8  ;  std_atm_pres_col(198) = 1.211E+04_r8
std_atm_hgt_col(199) =   10.0_r8  ;  std_atm_pres_col(199) = 2.650E+04_r8
std_atm_hgt_col(200) =    5.0_r8  ;  std_atm_pres_col(200) = 5.405E+04_r8
std_atm_hgt_col(201) =    0.0_r8  ;  std_atm_pres_col(201) = 1.013E+05_r8

std_atm_hgt_col(:) = std_atm_hgt_col(:) * 1000.0_r8


      DOUBLE PRECISION FUNCTION QUAGNO(F,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  QUANTILE FUNCTION OF THE GENERALIZED NORMAL DISTRIBUTION
C
C  OTHER ROUTINES USED: QUASTN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(3)
      DATA ZERO/0D0/,ONE/1D0/
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
      IF(A.LE.ZERO)GOTO 1000
      IF(F.LE.ZERO.OR.F.GE.ONE)GOTO 10
      Y=QUASTN(F)
      IF(G.NE.ZERO)Y=(ONE-DEXP(-G*Y))/G
      QUAGNO=U+A*Y
      RETURN
C
   10 IF(F.EQ.ZERO.AND.G.LT.ZERO)GOTO 20
      IF(F.EQ.ONE .AND.G.GT.ZERO)GOTO 20
      WRITE(6,7000)
      QUAGNO=ZERO
      RETURN
   20 QUAGNO=U+A/G
      RETURN
C
 1000 WRITE(6,7010)
      QUAGNO=ZERO
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE QUAGNO :',
     *  ' ARGUMENT OF FUNCTION INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE QUAGNO : PARAMETERS INVALID')
      END


!
! ej1b.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program ej1a

use precision,  pr => dp
use mtmod
use ising

implicit none
integer                             :: i, j, k, ii
integer, parameter                  :: u_max=1500
integer, dimension(:), allocatable  :: s
integer                             :: tmc, n_down, n_up, n_left, n_right
integer                             :: spinadd, loc, L, ntot, ntermal=10000
real(pr),dimension(0:u_max)         :: corr_e, corr_m, e_c, m_c
real(pr)                            :: e, m, d_e, r, T, Rp, e_w, m2, m4, dm, e2
real(pr)                            :: prob(-4:4, -1:1), L2, cv, xi
character (30)                      :: L1, Lchar

print *, "getting variables"

call get_command_argument(1, Lchar)
read(Lchar, *) L1
read(L1, *) L
print*,'L=',L
L2 = real(L*L, pr)
allocate(s(0:(L*L)-1))

36 format(8(ES14.6e2, 4X))

open(unit=10, file='neg_modL_'//trim(Lchar)//'_Tvar.dat', status='unknown')
write(10, *) "#m    m2    m4    e    e2    cv    xi    T"

! Inicializo la red de spines.
!  1 = up
! -1 = down
print*, 'Iniciando spins'
call spin_initialize(s, L)
s = -1*s
! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)
e_w = 0._pr
e2 = 0._pr

!magnetizacion inicial
m = 0
m2 = 0
m4 = 0

! dar vuelta la red por completo
! de forma ordenada
do ii = 99, 0, -1
    T = 0.01_pr + (ii/100._pr)*2.8_pr

    ! posibles deltas de energia
    call probability(prob, T)

    ! pasos de montecarlo
    do tmc =1, 100000

        ! recorro la red
        do k = 0, (L*L) -1
            call metropolis_pbc(k, L, s, e, prob)
        end do

        if (tmc > ntermal) then  ! descarto transitorio
            dm = sum(s)/L2
            m = m + dm
            m2 = m2 + dm*dm
            m4 = m4 + dm**4
            e_w = e_w + e/L2
            e2 = e2 + (e/L2)*(e/L2)
        end if

    end do

    ! calculo y guardo promedios
    ntot = real(tmc - ntermal, pr)
    m = m/ntot
    m2 = m2/ntot
    m4 = m4/ntot
    e_w = e_w/ntot
    e2 = e2/ntot

    xi = (-L2*(m*m - m2))/(2.2693*T)
    cv = (-L2*(e_w*e_w - e2))/(2.2693*T**2)

    write(10, 36) m, m2, m4, e_w, e2, cv, xi, T
    ! borro los acumuladores
    m = 0
    m2 = 0
    m4 = 0
    e_w = 0
    e2 = 0

end do
close(10)

end program


PROGRAM t_logistic
! Use the data from the file `surgical.dat'
! The printed versions of this data all have an error.
! We first test that this program detects the error.

USE Logistic_Regression
IMPLICIT NONE

INTEGER             :: ngroups = 40, n(40), s(40), count, i, pos, ndf, ier
REAL (dp)           :: x(40,3), chisq, devnce, beta(0:3), se_beta(0:3),  &
                       p(40), stdres(40), tail_prob
CHARACTER (LEN=80)  :: text
CHARACTER (LEN=40)  :: head
CHARACTER (LEN= 5)  :: age
CHARACTER (LEN= 1)  :: sex
CHARACTER (LEN= 6)  :: vname(0:3) = (/ 'Const.', 'Area  ', 'Age   ', 'Sex   ' /)

! Read the data

OPEN(UNIT=8, FILE='surgical.dat', STATUS='OLD')
count = 0
DO
  READ(8, '(a)') text
  IF (LEN_TRIM(text) == 0) CYCLE
  IF (text(1:1) == '!') THEN
    WRITE(*, '(" ",a)') TRIM(text)
  ELSE IF (text(1:1) == 'A') THEN
    head = TRIM(text)
  ELSE
    count = count + 1
    BACKSPACE(8)
    READ(8, '(f2.0, a7, a4, i9, i8)') x(count,1), age, sex, n(count), s(count)
    pos = INDEX(age, '-')
    READ(age(pos+1:pos+2), '(i2)') i
    IF (i == 0) THEN
      x(count,2) = 88.0_dp
    ELSE IF (i == 4) THEN
      x(count,2) = 2.0_dp
    ELSE
      x(count,2) = i - 4
    END IF
    IF (sex == 'M') THEN
      x(count,3) = 0
    ELSE
      x(count,3) = 1
    END IF
  END IF
  IF (count == 40) EXIT
END DO

WRITE(*, *)
CALL logistic(ngroups, x, 3, s, n, chisq, devnce, ndf, beta, se_beta, ier)
WRITE(*, *) '*** IER =', ier
WRITE(*, *)
WRITE(*, *) 'Data being corrected'
s(39) = 50
WRITE(*, *)

! Fit full model and report

CALL logistic(ngroups, x, 3, s, n, chisq, devnce, ndf, beta, se_beta, ier,  &
              fit=p, stdres=stdres)
IF (ier /= 0) THEN
  WRITE(*, *) 'Error number', ier
ELSE
  WRITE(*, '(a, f9.3, a, f9.3, a, i4, a)')  &
        ' Deviance = ', devnce, '   Chi-squared = ', chisq,   &
        ' with ', ndf, ' deg. of freedom'
  tail_prob = 1.0_dp - chi_squared(ndf, chisq)
  IF (tail_prob < 0.01_dp) THEN
    WRITE(*, *) '*** Significantly bad fit at the 1% level ***'
  END IF
  WRITE(*, '(a, g12.4/)') ' Chi-squared tail prob. = ', tail_prob
  WRITE(*, *) '        Coefficient   Std.error'
  DO i = 0, 3
    WRITE(*, '(" ", a6, "  ", 2g13.5)') vname(i), beta(i), se_beta(i)
  END DO

! Show fitted values
  WRITE(*, '(/a)') ' Area  Age  Sex  Patients  Died   Fitted  Std.Resid.'
  DO i = 1, ngroups
    WRITE(*, '(3f5.0, 2i8, 2f9.1)') x(i,1:3), n(i), s(i), n(i)*p(i), stdres(i)
  END DO
END IF

WRITE(*, *)
WRITE(*, *) 'From the standardized residuals, the model obviously does not'
WRITE(*, *) 'well for the youngest age group.'
WRITE(*, *)
WRITE(*, *) 'Leaving out the first age group'
WRITE(*, *)

! Removing cases 1, 2, 21 & 22.

x(1:18,:) = x(3:20,:)
n(1:18) = n(3:20)
s(1:18) = s(3:20)
x(19:36,:) = x(23:40,:)
n(19:36) = n(23:40)
s(19:36) = s(23:40)
ngroups = ngroups - 4

CALL logistic(ngroups, x, 3, s, n, chisq, devnce, ndf, beta, se_beta, ier,  &
              fit=p, stdres=stdres)
IF (ier /= 0) THEN
  WRITE(*, *) 'Error number', ier
ELSE
  WRITE(*, '(a, f9.3, a, f9.3, a, i4, a)')  &
        ' Deviance = ', devnce, '   Chi-squared = ', chisq,   &
        ' with ', ndf, ' deg. of freedom'
  tail_prob = 1.0_dp - chi_squared(ndf, chisq)
  IF (tail_prob < 0.01_dp) THEN
    WRITE(*, *) '*** Significantly bad fit at the 1% level ***'
  END IF
  WRITE(*, '(a, g12.4/)') ' Chi-squared tail prob. = ', tail_prob
  WRITE(*, *) '        Coefficient   Std.error'
  DO i = 0, 3
    WRITE(*, '(" ", a6, "  ", 2g13.5)') vname(i), beta(i), se_beta(i)
  END DO

! Show fitted values
  WRITE(*, '(/a)') ' Area  Age  Sex  Patients  Died   Fitted  Std.Resid.'
  DO i = 1, ngroups
    WRITE(*, '(3f5.0, 2i8, 2f9.1)') x(i,1:3), n(i), s(i), n(i)*p(i), stdres(i)
  END DO
END IF

WRITE(*, *)
WRITE(*, *) 'The model still does not fit well, though it fits better now.'
WRITE(*, *) 'There appears to be no difference between areas, but the'
WRITE(*, *) 'difference between sexes is significant'

STOP
END PROGRAM t_logistic


! Library containing a number ad hoc routines relating to linear algebra.
!
! Description
! -----------
!
! For the most part, this code wraps existing LAPACK routines to
! perform linear algebra operations in a more straightforward
! fashion.
!
! Author
! ------
!
! Stanislav Sokolenko, University of Waterloo
!
! History
! -------
!
! June 23/2014
!   - brought over "v_norm" from previous code
!   - brought over "m_svd" from previous code
!   - brought over "m_rank" from previous code
!   - brought over "m_nullity" from previous code
!   - brought over "m_kernel" from previous code
! July 27/2014
!   - added "v_ssq"

module algebra

  implicit none
  private

  !=====================================================================>
  ! Interfaces with LAPACK

  !---------------------------------------------------------------------
  ! singular value decomposition
  interface
    subroutine dgesdd(jobz, m, n, A, lda, s, U, ldu, VT, ldvt,                &
                      work, lwork, iwork, info)
      character :: jobz
      integer :: info, lda, ldu, ldvt, lwork, m, n
      integer :: iwork(*)
      double precision :: A(lda, *), s(*), U(ldu, *), VT(ldvt, *), work(*)
    end subroutine dgesdd
  end interface

  !---------------------------------------------------------------------
  ! sum of squares
  interface
    subroutine dlassq(n, x, incx, scale, sumsq)
      integer, intent(in) :: n, incx
      double precision, intent(in) :: x(*)
      double precision, intent(inout) :: scale, sumsq
    end subroutine dlassq
  end interface

  public :: v_norm, v_ssq, m_svd, m_rank, m_nullity, m_kernel

  contains

    !===================================================================>
    ! Convenience functions and subroutines relating to basic linear
    ! algebra

    !-------------------------------------------------------------------
    function v_ssq(x)
      ! Calculates the squared sum of a vector using Lapack's dlassq
      !
      ! Parameters
      ! ----------
      ! x: double precision(:)
      !   Vector whose norm is to be calculated
      !
      ! Returns
      ! -------
      ! v_norm: double precision
      !   Vector norm of x.

      ! Function arguments
      double precision, intent(in) :: x(:)
      double precision :: v_ssq

      ! Local variables
      integer :: n, incx
      double precision :: scale, sumsq

      n = size(x)
      incx = 1

      scale = 0d0
      sumsq = 1d0

      call dlassq(n, x, incx, scale, sumsq)

      v_ssq = scale**2 * sumsq

    end function v_ssq

    !-------------------------------------------------------------------
    function v_norm(x)
      ! Calculates the norm of a vector using Lapack's dlassq
      !
      ! Parameters
      ! ----------
      ! x: double precision(:)
      !   Vector whose norm is to be calculated
      !
      ! Returns
      ! -------
      ! v_norm: double precision
      !   Vector norm of x.

      ! Function arguments
      double precision, intent(in) :: x(:)
      double precision :: v_norm

      v_norm = sqrt(v_ssq(x))

    end function v_norm

    !===================================================================>
    ! Convenience functions and subroutines relating to singular value
    ! decomposition and eigenvalue calculation.

    !-------------------------------------------------------------------
    subroutine m_svd(A, m, n, U, s, VT, job)
      ! Performs singular value decomposition of A.
      !
      ! A = U * sigma * transpose(V)
      !
      ! Parameters
      ! ----------
      ! A: double precision (m, n)
      !   The array on which the singular value decomposition is to be
      !   performed.
      ! m: integer
      !   Row number of A.
      ! n: integer
      !   Column number of A.
      ! job: character (1)
      !   'A' to compute U, s, and VT; 'N' to compute only s
      !
      ! Returns
      ! -------
      ! U: double precision (m, m)
      ! s: double precision (min(m, n))
      !   Diagonal element of sigma and singular values of A.
      ! VT: double precision (n, n)
      !   The transpose of V.

      ! Subroutine arguments
      character, intent(in) :: job
      integer, intent(in) :: m, n
      double precision, intent(in) :: A(m, n)
      double precision, intent(out) :: U(m, m), s(min(m, n)), VT(n, n)

      ! Local variables
      integer :: lwork, lda, ldu, ldvt, info
      double precision :: work_query(1), A_work(m, n)

      integer, allocatable :: iwork(:)
      double precision, allocatable :: work(:)

      ! Copying A so it's not destroyed
      A_work = A

      ! Variable assignment
      lda = m
      ldu = m
      ldvt = n

      allocate(iwork(8*min(m, n)))

      ! Determining optimal lwork
      lwork = -1
      info = 0
      call dgesdd(job, m, n, A_work, lda, s, U, ldu, VT, ldvt,                &
                  work_query, lwork, iwork, info)

      ! Allocating appropriately sized work array
      lwork = nint(work_query(1))
      allocate(work(lwork))

      ! Performing SVD
      call dgesdd(job, m, n, A_work, lda, s, U, ldu, VT, ldvt,                &
                  work, lwork, iwork, info)

    end subroutine m_svd

    !-------------------------------------------------------------------
    function m_rank(A)
      ! Calculates rank of matrix A by performing singular value
      ! decomposition and counting non-zero singular values.
      !
      ! Parameters
      ! ----------
      ! A: double precision (m, n)
      !   The array for which the rank is calculated.
      !
      ! Returns
      ! -------
      ! m_rank: integer
      !   Rank of A.

      ! Subroutine arguments
      double precision, intent(in) :: A(:, :)
      integer :: m_rank

      ! Local variables
      integer :: A_dim(2), m, n
      double precision, allocatable :: U(:, :), s(:), VT(:, :)

      ! Variable assignment
      A_dim = shape(A)
      m = A_dim(1)
      n = A_dim(2)

      allocate(U(m, m))
      allocate(s(min(m, n)))
      allocate(VT(n, n))

      call m_svd(A, m, n, U, s, VT, 'N')

      m_rank = count(abs(s) > 1d-8)

    end function m_rank

    !-------------------------------------------------------------------
    function m_nullity(A)
      ! Calculates rank of the nullspace of matrix A by first
      ! calculating the rank through singular value decomposition.
      !
      ! Parameters
      ! ----------
      ! A: double precision (m, n)
      !   The array for which the nullity is calculated.
      !
      ! Returns
      ! -------
      ! m_nullity: integer
      !   Nullity of A.

      ! Subroutine arguments
      double precision, intent(in) :: A(:, :)
      integer ::m_nullity

      ! Local variables
      integer :: A_dim(2)

      A_dim = shape(A)
      m_nullity = A_dim(2) - m_rank(A)

    end function m_nullity

    !-------------------------------------------------------------------
    function m_kernel(A)
      ! Calculates the nullspace of A.
      !
      ! Parameters
      ! ----------
      ! A: double precision (m, n)
      !   The array for which the nullspace is calculated.
      !
      ! Returns
      ! -------
      ! m_kernel: double precision
      !   Nullspace of A.

      ! Subroutine arguments
      double precision, intent(in) :: A(:, :)
      double precision, allocatable ::m_kernel(:, :)

      ! Local variables
      integer :: A_dim(2), m, n, nullity
      double precision, allocatable :: U(:, :), s(:), VT(:, :)

      ! Getting nullspace dimensions
      nullity = m_nullity(A)

      ! Calculating VT matrix
      A_dim = shape(A)
      m = A_dim(1)
      n = A_dim(2)

      allocate(U(m, m))
      allocate(s(min(m, n)))
      allocate(VT(n, n))

      call m_svd(A, m, n, U, s, VT, 'A')

      ! Extracting nullspace
      allocate(m_kernel(n, nullity))

      m_kernel = transpose(VT((n - nullity + 1):n, :))

    end function m_kernel

end module algebra


      PROGRAM ANRTST
C------------------------------------------------------------------
C FORTRAN 77 program to test ANORM, the normal probability integral.
C
C  Method:
C
C     Accuracy test compares function values against local Taylor's
C     series expansions.  Derivatives for anorm(x) are expressed as
C     repeated integrals of erfc(-x/sqrt(2)).  These are generated
C     from the recurrence relation using a technique due to Gautschi
C     (see references).
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the
C                       significant of a floating-point number
C              EPS    - The smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - The smallest non-vanishing floating-point
C                       integral power of the radix
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  References: "Performance evaluation of programs for the error
C               and complementary error functions", W. J. Cody,
C               TOMS 16, 1990, pp. 29-37.
C
C              "Evaluation of the repeated integrals of the coerror
C               function", W. Gautschi, TOMS 3, 1977, pp. 240-252.
C
C  Latest modification: March 15, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,N0,N1
CS    REAL  ANORM,
      DOUBLE PRECISION ANORM,
     1    A,AIT,ALBETA,B,BETA,C,CONV,C1,C2,DEL,EPS,EPSCON,EPSNEG,FF,
     2    F0,HALF,ONE,R,REN,ROOT32,R1,R6,R7,SC,SIXTEN,SQRTWO,THRESH,
     3    TEN,TWO,U,V,W,X,XBIG,XC,XL,XMAX,XMIN,XN,XN1,X99,Y,Z,ZERO
      DIMENSION R1(500)
C------------------------------------------------------------------
C   C1 = 1/sqrt(pi)
C------------------------------------------------------------------
CS    DATA HALF,ZERO,ONE,TWO,TEN/0.5E0,0.0E0,1.0E0,2.0E0,10.0E0/,
CS   1     SIXTEN,THRESH,X99/16.0E0,0.66291E0,-999.0E0/,
CS   2     C1/5.6418958354775628695E-1/,ROOT32/-5.65685E0/,
CS   3     SQRTWO/7.0710678118654752440E-1/
      DATA HALF,ZERO,ONE,TWO,TEN/0.5D0,0.0D0,1.0D0,2.0D0,10.0D0/,
     1     SIXTEN,THRESH,X99/16.0D0,0.66291D0,-999.0D0/,
     2     C1/5.6418958354775628695D-1/,ROOT32/-5.65685D0/,
     3     SQRTWO/7.0710678118654752440D-1/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
      CONV(I) = DBLE(I)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      C = ABS(AIT*ALBETA) + TEN
      A = -THRESH
      B = THRESH
      N = 2000
      XN = CONV(N)
      JT = 0
      N0 = (IBETA/2)*(IT+5)/6+4
C-----------------------------------------------------------------
C  Determine largest argument for ANORM test by Newton iteration
C-----------------------------------------------------------------
      C2 = LOG(XMIN/C1/SQRTWO)
      XBIG = SQRT(-C2)
   50 X = XBIG
         F0 = X*X
         FF = F0 *HALF + ONE/F0 + LOG(X) + C2
         F0 = X + ONE/X - TWO/(X*F0-X)
         XBIG = X - FF/F0
         IF (ABS(X-XBIG)/X .GT. TEN*EPS) GO TO 50
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 3
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            IF (J .EQ. 1) THEN
C-----------------------------------------------------------------
C  Test anorm against double series expansion
C-----------------------------------------------------------------
                  F0 = CONV(N0)
                  FF = F0+F0+ONE
                  W = X*X
                  Z = W*HALF
                  U = ZERO
                  V = ZERO
                  DO 60 K = 1, N0
                     U = -Z/F0*(ONE+U)
                     V = W/FF*(ONE+V)
                     F0 = F0 - ONE
                     FF = FF - TWO
   60             CONTINUE
                  V = HALF + SQRTWO*C1*X*(((U*V+(U+V))+HALF)+HALF)
                  U = ANORM(X)
               ELSE
C-----------------------------------------------------------------
C  Test anorm against expansion in repeated
C   integrals of the coerror function.
C-----------------------------------------------------------------
                  Y = X - HALF
                  X = Y + HALF
                  U = ANORM(X)
                  Z = -Y/SQRT(TWO)
                  R = ZERO
                  IF (Z .LE. ONE) THEN
                        N0 = 499
                     ELSE
                        N0 = MIN(499,INT(C/(ABS(LOG(Z)))))
                  END IF
                  N1 = N0
                  XN1 = CONV(N1+1)
                  DO 100 K=1,N0
                     R = HALF/(Z+XN1*R)
                     R1(N1) = R
                     N1 = N1 - 1
                     XN1 = XN1 - ONE
  100             CONTINUE
                  FF = C1/(Z+R1(1))
                  F0 = ANORM(Y)*EXP((-Y-HALF*HALF)*HALF)
                  SC = F0/FF
C-----------------------------------------------------------------
C  Scale things to avoid premature underflow
C-----------------------------------------------------------------
                  EPSCON = F0
                  FF = SIXTEN*FF/EPS
                  DO 110 N1=1,N0
                     FF = R1(N1)*FF
                     R1(N1) = FF * SC
                     IF (R1(N1) .LT. EPSCON ) THEN
                        K = N1
                        GO TO 111
                     END IF
  110             CONTINUE
  111             V = SQRTWO*R1(K)
                  DO 120 N1 = 1, K-1
                     V = (V + R1(K-N1))*SQRTWO
  120             CONTINUE
C-----------------------------------------------------------------
C  Remove scaling here
C-----------------------------------------------------------------
                  V = V*EPS/SIXTEN + F0
            END IF
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (U - V) / U
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
            ELSE
               WRITE (IOUT,1001)
         END IF
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1
         WRITE (IOUT,1015) K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         IF (J .EQ. 1) THEN
               B = A
               A = ROOT32
            ELSE
               B = A
               A = -AINT(XBIG*SIXTEN)/SIXTEN+HALF
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C  First check values for positive arguments.
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1030)
      DEL = TEN
      DO 350 I = 1, 10
         X = REN(JT) * DEL
         U = ANORM(-X)
         A = U + ANORM(X)
         Y = (A - HALF) - HALF
         WRITE (IOUT,1032) X, U, Y
  350 CONTINUE
C-----------------------------------------------------------------
C  Test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      Z = XMAX
      Y = ANORM(Z)
      WRITE (IOUT,1041) Z,Y
      Z = ZERO
      Y = ANORM(Z)
      WRITE (IOUT,1041) Z,Y
      Z = -XMAX
      Y = ANORM(Z)
      WRITE (IOUT,1041) Z,Y
C-----------------------------------------------------------------
C  Test of error returns
C-----------------------------------------------------------------
      WRITE (IOUT,1050)
      W = XBIG
      Z = -W*(ONE-HALF*HALF)
      WRITE (IOUT,1052) Z
      Y = ANORM(Z)
      WRITE (IOUT,1062) Y
      Z = -W*(ONE+TEN*EPS)
      WRITE (IOUT,1053) Z
      Y = ANORM(Z)
      WRITE (IOUT,1062) Y
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of anorm(x) vs double series expansion'//)
 1001 FORMAT(///' Test of anorm(x) vs Taylor series about x-1/2'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT('  ANORM(X) was larger',I6,' times,')
 1015 FORMAT(14X,' agreed',I6,' times, and'/
     1    10X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1030 FORMAT(7X,'Check of identity anorm(X) + anorm(-X) = 1.0'//
     1       9X,'X',12X,'ANORM(-x)',3X,'ANORM(x)+ANORM(-x)-1'/)
c     1032 FORMAT(3(3X,E13.6E3)/)
 1032 FORMAT(3X,E13.6E3,3X,E13.6E3,3X,E13.6E3/)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT(' ANORM (',E13.6E3,') = ',E13.6E3//)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' ANORM will be called with the argument ',E13.6E3,/
     1    ' The result should not underflow'//)
 1053 FORMAT(' ANORM will be called with the argument ',E13.6E3,/
     1    ' The result may underflow'//)
 1062 FORMAT(' ANORM returned the value',E13.6E3///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of ANORM test program ----------
      END


module basis

! Gaussian Type Orbitals (GTO) basis utilities.

! Primitive gaussian is described by (l, m, n), norm, coef, alpha,
! (xcenter, ycenter, zcenter). The normalization is given by norm_prim(), which
! is just a simple formula. The "coef" is used as a coefficient in the
! contracted gaussian:
!
! Contracted gaussian is described by "nprim" primitive gaussians with the same
! (l, m, n). For example with nprim=6, we can have:
!           1264.58570000           0.00194480
!            189.93681000           0.01483510
!             43.15908900           0.07209060
!             12.09866300           0.23715420
!              3.80632320           0.46919870
!              1.27289030           0.35652020
! This corresponds to 6 primitive gaussians (alpha, coef) pairs. Contraction
! can also have just one primitive gaussian (nprim=1).
! Important note: the coefficients above are given relative to *normalized*
! primitive gaussians (this is the standard). So one first has to normalize the
! primitive gaussian, then multiply by the coefficient and only then normalize
! the whole contracted gaussian as described below.
!
! lambda = l+m+n (0=S, 1=P, 2=D, 3=F, ...) is angular momentum/orbital quantum
! number.
! The basis set file contains pairs of (lambda, contracted gaussian)
! for each atom. For example the 6-31G** basis contains:
!   He: (S, S, P)           # i.e. 1s, 2s, 2p
!   Be: (S, S, P, S, P, D)  # i.e. 1s, 2s, 2p, 3s, 3p, 3d
! To each "S, P, D, F" there is one contracted gaussian, which is described for
! example by the (alpha, coef) pairs above.
! Normalization of a contracted gaussian is so that the overlap integral is 1
! (for example the overlap matrix S must have 1.0 on the diagonal).
! More info at [2].
! The contracted gaussian is given by (l, m, n), norm, (xcenter, ycenter,
! zcenter) and "nprim" pairs of (alpha, coef).
!
! Shell is a set of contracted Gaussians for all possible combinations of (l, m
! n) for the given lambda. All other parameters stay the same, so the shell is
! given by: lambda, norm, (xcenter, ycenter, zcenter) and "nprim" pairs of
! (alpha, coef). There are two possibilities:
!
! 1) Cartesian Gaussians shell: there are (lambda+1)*(lambda+2)/2 contracted
! gaussians (all combinations of (n, l, m) so that lambda=n+l+m)
!
! 2) Spherical Gaussians shell: there are 2*lambda+1 contracted gaussians (all
! combinations of "m" for the given l=lambda for the spherical harmonic Y_lm)
!
! l    2l+1     (l+1)(l+1)/2   =decomposition in l      sum of 2l+1
! 0s     1           1              0                   1            =  1
! 1p     3           3              1                     3          =  3
! 2d     5           6              0,2                 1 + 5        =  6
! 3f     7          10              1,3                   3 + 7      = 10
! 4g     9          15              0,2,4               1 + 5 + 9    = 15
! 5h    11          21              1,3,5                 3 + 7 + 11 = 21
!
! So for l = 0, 1 the number of basis functions is the same, but for l >= 2 the
! Cartesian Gaussians have more functions. The homogeneous polynomials of order
! "n" in (x, y, z) span the symmetric (n+1)(n+2)/2-dimensional reducible
! representation of the U(3) group. The spherical harmonics Y_lm span the 2l+1
! dimensional irreducible representation of the SO(3) group, which is a
! subgroup of U(3).  From the table above, s, p is the same, cartesian d is
! composed of five spherical d and one s (total of 6 functions), cartesian h is
! composed of three p, seven f and eleven h (total 21 functions).  See [1] for
! more info.
!
! [1] Schlegel, H. B., & Frisch, M. J. (1995). Transformation Between Cartesian
! and Pure Spherical Harmonic Gaussians. International Journal of Quantum
! Chemistry, 54(2), 83-87.
!
! [2] http://www.files.chem.vt.edu/chem-dept/valeev/docs/ints.pdf

! In this file, we only use Cartesian GTO and each shell has exactly
! (lambda+1)*(lambda+2)/2 contracted GTO. The ordering of the (n, l, m)
! triplets is given by the get_cartesian_shell() function.

use types, only: dp
use constants, only: pi
use utils, only: stop_error, lowcase, str, assert, newunit
use qc, only: getS, getT, getV, coulomb_repulsion
use gaussians, only: getints2
use scf, only: ijkl2intindex
use basis_aux, only: get_2ints_size
implicit none
private
public get_cartesian_shell, getstart, gaussints, get_2ints_size

contains

elemental real(dp) function norm_prim(l, m, n, alpha) result(norm)
integer, intent(in) :: l, m, n
real(dp), intent(in) :: alpha
norm = sqrt(2**(2*(l+m+n)+1.5)*alpha**(l+m+n+1.5_dp) / &
    fact2(2*l-1)/fact2(2*m-1)/fact2(2*n-1)/pi**(1.5_dp))
end function

pure real(dp) function norm_contr(l, m, n, alpha, coefu) result(norm)
! Calculates the normalization coefficient of a contracted GTO specified by (l,
! m, n) and (alpha, coefu) pairs. The "coefu" here is given with regards to
! *unnormalized* primitive GTOs (thus the "u" in "coefu"), so the normalized
! contracted GTO is then given by:
!     norm_contr * sum_i coefu(i) * GTO(l, m, n, alpha(i))
!
! Note: if there is only one primitive GTO in the contraction (that is,
! size(alpha)==size(coefu)==1), then norm_contr() is equivalent to
! norm_prim(), that is, norm_contr = norm_prim / coefu(1):
!
!    norm_contr * coefu(1) * GTO(l, m, n, alpha(1)) =
!       = norm_prim / coefu(1) * coefu(1) * GTO(l, m, n, alpha(1)) =
!       = norm_prim * GTO(l, m, n, alpha(1))
!
! (l, m, n) of the contracted GTO:
integer, intent(in) :: l, m, n
! Alpha exponents of primitive GTOs:
real(dp), intent(in) :: alpha(:)
! Coefficients with regards to *unnormalized* primitive GTOs:
real(dp), intent(in) :: coefu(:)
real(dp) :: L_, S
integer :: i, j
L_ = l + m + n
S = 0
do i = 1, size(alpha)
    do j = 1, size(alpha)
        S = S + coefu(i)*coefu(j)/(alpha(i)+alpha(j))**(L_+3._dp/2)
    end do
end do
norm = 1/pi**(3._dp/4) * sqrt(2**L_/ fact2(2*l-1)/fact2(2*m-1)/fact2(2*n-1)) / &
    sqrt(S)
end function

pure recursive real(dp) function fact2(n) result(r)
integer, intent(in) :: n
if (n <= 1) then
    r = 1
else
    r = n * fact2(n-2)
end if
end function

subroutine read_basis(Z, L, nprim, c, zeta)
! Reads the basis corresponding to the atom Z from the file.
! Currently it reads the 6-31G** basis.
! This function doesn't do any transformation on the basis, so it only returns
! the set of contracted GTO shells, that are specified in the basis file.

integer, intent(in) :: Z ! atomic number

! The contracted gaussian L number. L(i) is the L number of the i-th shell:
integer, allocatable, intent(out) :: L(:)

! nprim(i) is the number of primitive GTO that compose the given contracted GTO
! of the i-th shell. size(nprim) == size(L)
integer, allocatable, intent(out) :: nprim(:)

! Coefficients and zeta of the primitive gaussians.
! size(c) == size(zeta), the first nprim(1) correspond to the first
! contracted Gaussian, the next nprim(2) correspond to the second
! contracted Gaussian and so on.
real(dp), allocatable, intent(out) :: c(:), zeta(:)
!
! Important note: the coefficients c(:) are with respect to *normalized*
! primitive GTO.
!
! Example:
! --------
!
! Given the part of input file for Lithium (Z=3):
!
! 3
! 6
! S 6
!             642.41892000           0.00214260
!              96.79851500           0.01620890
!              22.09112100           0.07731560
!               6.20107030           0.24578600
!               1.93511770           0.47018900
!               0.63673580           0.34547080
! S 3
!               2.32491840          -0.03509170
!               0.63243060          -0.19123280
!               0.07905340           1.08398780
! P 3
!               2.32491840           0.00894150
!               0.63243060           0.14100950
!               0.07905340           0.94536370
! S 1
!               0.03596200           1.00000000
! P 1
!               0.03596200           1.00000000
! D 1
!               0.20000000           1.00000000
!
! There are 6 shells and the output arrays will be:
!
! L     = [0, 0, 1, 0, 1, 2]
! nprim = [6, 3, 3, 1, 1, 1]
! zeta  = [642.41892000, 96.79851500, ..., 0.03596200, 0.20000000]
! c     = [0.00214260, 0.01620890, ..., 1.00000000, 1.00000000]
!
! The coefficients c(:) are with respect to normalized GTOs. From this it
! follows that primitive GTO corresponding to nprim(i)=1 will have a
! coefficient equal to 1.0. In order to obtain coefficients with respect to
! unnormalized GTOs, one has to multiply each c(:) by the norm factor (in
! general there will be no "1.0"s).

integer :: u, ZZ, ios
open(newunit(u), file="p631ss.txt", status="old") ! 6-31G**
do
    read(u, *, iostat=ios) ZZ
    if (ios /= 0) then
        call stop_error("read_basis: atom Z=" // str(Z) // " not found")
    end if
    call read_atom(u, L, nprim, c, zeta)
    if (ZZ == Z) then
        close(u)
        return
    end if
end do
end subroutine

subroutine read_atom(u, L, nprim, c, zeta)
! Reads the basis of one atom from the file "u".
! The meaning of L, nprim, c and zeta is the same as in read_basis().
integer, intent(in) :: u
integer, allocatable, intent(out) :: L(:), nprim(:)
real(dp), allocatable, intent(out) :: c(:), zeta(:)
integer, parameter :: MAX_FCN = 100
real(dp), dimension(MAX_FCN) :: c_tmp, zeta_tmp
character :: Ltmp
integer :: r, i, j, idx
read(u, *) r
allocate(L(r), nprim(r))
idx = 0
do i = 1, r
    read(u, *) Ltmp, nprim(i)
    L(i) = str2l(Ltmp)
    do j = 1, nprim(i)
        idx = idx + 1
        if (idx > MAX_FCN) call stop_error("read_atom: increase MAX_FCN")
        read(u, *) zeta_tmp(idx), c_tmp(idx)
    end do
end do
allocate(c(idx), zeta(idx))
c = c_tmp(:idx)
zeta = zeta_tmp(:idx)
end subroutine

integer function str2l(s) result(l)
character, intent(in) :: s
select case(lowcase(s))
    case ("s")
        l = 0
    case ("p")
        l = 1
    case ("d")
        l = 2
    case ("f")
        l = 3
    case ("g")
        l = 4
    case ("h")
        l = 5
    case ("i")
        l = 6
    case default
        l = -1 ! Suppress compiler warning
        call stop_error("str2l: unknown angular momentum '" // s // "'")
end select
end function

subroutine get_basis(atZ, at_xyz, L, nprim, center, coef, alpha)
! Returns the basis as a list of *shells*.

! The input are atomic coordinates and numbers (atZ, at_xyz),
! The output are arrays "L(i), nprim(i), center(i)"
! describing i-th shell. The arrays "coef, alpha" contain the primitive GTOs of
! all shells together in consecutive order. In order to obtain coef, alpha
! for the i-th shell, do:
!     istart = getstart(nprim)
!     print *,  coef(istart(i):istart(i)+nprim(i)-1)
!     print *, alpha(istart(i):istart(i)+nprim(i)-1)

integer, intent(in) :: atZ(:) ! atZ(i) is the atomic number of the i-th atom
! at_xyz(:, i) are (x,y,z) coordinates of the i-th atom
real(dp), intent(in) :: at_xyz(:, :)
! L(i) is the lambda of the i-th shell
integer, intent(out), allocatable :: L(:)
! nprim(i) is the number of primitive GTO in the i-th shell:
integer, intent(out), allocatable :: nprim(:)
! center(:, i) are the xyz coordinates of the i-th shell
real(dp), intent(out), allocatable :: center(:, :)
! The coefficients (with regards to normalized GTO) and alpha's of primitive
! gaussians:
real(dp), intent(out), allocatable :: coef(:), alpha(:)

! Max length of the temporary arrays:
integer, parameter :: N = 10000
integer, allocatable :: at_nprim(:), at_L(:)
real(dp), allocatable :: at_center(:, :)
real(dp), allocatable :: at_coef(:), at_alpha(:)
integer :: tmp_L(N)
integer :: tmp_nprim(N)
real(dp) :: tmp_center(3, N)
real(dp) :: tmp_coef(N), tmp_alpha(N)
integer :: i, j
integer :: nc, np, atc, atp
nc = 0
np = 0
do i = 1, size(atZ)
    call read_basis(atZ(i), at_L, at_nprim, at_coef, at_alpha)
    allocate(at_center(3, size(at_L)))
    do j = 1, size(at_L)
        at_center(:, j) = at_xyz(:, i)
    end do

    atc = size(at_nprim)
    atp = size(at_coef)
    if (nc+atc > N .or. np+atp > N) then
        call stop_error("get_basis() internal error: Increase N")
    end if
    tmp_L(nc+1:nc+atc) = at_L
    tmp_nprim(nc+1:nc+atc) = at_nprim
    tmp_center(:, nc+1:nc+atc) = at_center

    tmp_coef(np+1:np+atp) = at_coef
    tmp_alpha(np+1:np+atp) = at_alpha

    nc = nc + atc
    np = np + atp
    deallocate(at_center)
end do
allocate(L(nc), nprim(nc), center(3, nc))
allocate(coef(np), alpha(np))
L = tmp_L(:nc)
nprim = tmp_nprim(:nc)
center = tmp_center(:, :nc)

coef = tmp_coef(:np)
alpha = tmp_alpha(:np)
end subroutine

subroutine fix_normalization(nprim, istart, power, coefu, alpha)
! Determines the correct normalization using the overlap integral.
! The result is saved in 'coefu'.
integer, intent(in), allocatable :: nprim(:)
integer, intent(in), allocatable :: istart(:)
integer, intent(in), allocatable :: power(:, :)
! Coefficients with regards to *unnormalized* primitive gaussians
real(dp), intent(inout), allocatable :: coefu(:)
real(dp), intent(in), allocatable :: alpha(:)
integer, dimension(size(power, 2)) :: l, m, n
integer :: i, i1, i2
real(dp) :: norm
l = power(1, :)
m = power(2, :)
n = power(3, :)
do i = 1, size(nprim)
    if (nprim(i) > 1) then
        i1 = istart(i)
        i2 = i1 + nprim(i)-1
        norm = norm_contr(l(i), m(i), n(i), alpha(i1:i2), coefu(i1:i2))
        coefu(i1:i2) = coefu(i1:i2) * norm
    end if
end do
end subroutine

subroutine get_cartesian_shell(L, lpower, mpower, npower)
! Returns all the functions on the "L" Cartesian shell.
! The Cartesian shell is defined as (x^l, y^m, z^n) where the powers (l, m, n)
! are given by all combinations of l,m,n <= L so that l+m+n=L. There
! is exactly (L+1)(L+2)/2 such combinations.
! There are several ways how one can order these combinations. This subroutine
! uses the following ordering:
! L = 0
! lpower == [0]
! mpower == [0]
! npower == [0]
! L = 1
! lpower == [1, 0, 0]
! mpower == [0, 1, 0]
! npower == [0, 0, 1]
! L = 2
! lpower == [2, 1, 1, 0, 0, 0]
! mpower == [0, 1, 0, 2, 1, 0]
! npower == [0, 0, 1, 0, 1, 2]
! L = 3
! lpower == [3, 2, 2, 1, 1, 1, 0, 0, 0, 0]
! mpower == [0, 1, 0, 2, 1, 0, 3, 2, 1, 0]
! npower == [0, 0, 1, 0, 1, 2, 0, 1, 2, 3]
! ...

integer, intent(in) :: L  ! The Gaussian orbital number
integer, intent(out), dimension(:) :: lpower, mpower, npower
! the (l, m, n) powers. The arrays must have dimension (L+1)(L+2)/2
integer :: i, k, n
i = 1
do k = 0, L
    do n = 0, k
        lpower(i) = L - k
        mpower(i) = k - n
        npower(i) = n
        i = i + 1
    end do
end do
end subroutine

function getstart(nprim) result(istart)
! Calculates the start of the primitive gaussians for the given shell ("nprim")
! Example:
! nprim  = [6, 3, 3, 1, 1, 1]
! istart = [1, 7, 10, 13, 14, 15]
integer, intent(in) :: nprim(:)
integer :: istart(size(nprim))
integer :: i
istart(1) = 1
do i = 2, size(nprim)
    istart(i) = istart(i-1) + nprim(i-1)
end do
end function

subroutine shells2contracted_gto(s_L, s_nprim, s_center, s_coef, s_alpha, &
    nprim, center, power, istart, coef, alpha)
! Converts basis in terms of shell to a basis in terms of contracted GTO

! Basis in terms of shells:
integer, intent(in) :: s_L(:)
integer, intent(in) :: s_nprim(:)
real(dp), intent(in) :: s_center(:, :)
real(dp), intent(in) :: s_coef(:), s_alpha(:)

! Basis in terms of contracted GTO:
integer, allocatable, intent(out) :: nprim(:)
real(dp), allocatable, intent(out) :: center(:, :)
integer, allocatable, intent(out) :: power(:, :)
integer, allocatable, intent(out) :: istart(:)
real(dp), allocatable, intent(out) :: coef(:), alpha(:)

integer, allocatable :: lpower(:), mpower(:), npower(:)
integer, allocatable :: s_istart(:)
real(dp), allocatable :: normp(:)
integer :: i, j, n, c, m, n2, iprim, lambda, i1, i2, k

allocate(s_istart(size(s_nprim)))
s_istart = getstart(s_nprim)
m = sum((s_L+1)*(s_L+2)/2) ! Total number of contracted GTO
allocate(nprim(m), center(3, m), power(3, m), istart(m))
c = 1
do i = 1, size(s_nprim)
    n = (s_L(i)+1)*(s_L(i)+2)/2  ! Number of contracted GTO in the shell
    allocate(lpower(n), mpower(n), npower(n))
    call get_cartesian_shell(s_L(i), lpower, mpower, npower)
    nprim (   c:c+n-1) = s_nprim(i)
    do j = 1, 3
        center(j, c:c+n-1) = s_center(j, i)
    end do
    power (1, c:c+n-1) = lpower
    power (2, c:c+n-1) = mpower
    power (3, c:c+n-1) = npower
    c = c + n
    deallocate(lpower, mpower, npower)
end do
istart = getstart(nprim)
n2 = istart(m) + nprim(m) - 1
allocate(normp(n2), coef(n2), alpha(n2))
iprim = 1
i = 1
do
    lambda = sum(power(:, i))
    ! Loop over all "l" for the given Cartesian shell
    do k = 1, (lambda+1)*(lambda+2)/2
        i1 = istart(i)
        i2 = i1 + nprim(i) - 1
        coef(i1:i2) = s_coef(iprim:iprim+nprim(i)-1)
        alpha(i1:i2) = s_alpha(iprim:iprim+nprim(i)-1)
        normp(i1:i2) = norm_prim(power(1, i), power(2, i), power(3, i), &
            alpha(i1:i2))
        i = i + 1
    end do
    iprim = iprim + nprim(i-1)
    if (i > m) exit
end do
coef = coef*normp
call fix_normalization(nprim, istart, power, coef, alpha)
end subroutine

subroutine gaussints(atno, xyz, S, T, V, int2)
integer, intent(in) :: atno(:) ! Atomic numbers (Z)
real(dp), intent(in) :: xyz(:, :) ! Atomic coordinates (3, :)
real(dp), allocatable, intent(out) :: S(:, :), & ! Overlap matrix
    T(:, :), &  ! Kinetic matrix
    V(:, :), &  ! Potential matrix
    int2(:)     ! Two particle integrals indexed using ijkl2intindex()

integer :: Nelec

! Basis in terms of shells:
integer, allocatable :: s_L(:)
integer, allocatable :: s_nprim(:)
real(dp), allocatable :: s_center(:, :)
real(dp), allocatable :: s_coef(:), s_alpha(:)

! Basis in terms of contracted GTO:
integer, allocatable :: nprim(:)
real(dp), allocatable :: center(:, :)
real(dp), allocatable :: xcenter(:), ycenter(:), zcenter(:)
integer, allocatable :: power(:, :)
integer, allocatable :: lpower(:), mpower(:), npower(:)
integer, allocatable :: istart(:)
real(dp), allocatable :: coef(:), alpha(:)

real(dp), dimension(size(atno)) :: xatom, yatom, zatom

integer :: i
integer :: n, m

Nelec = sum(atno)

print *, "Creating the basis..."
call get_basis(atno, xyz, s_L, s_nprim, s_center, s_coef, s_alpha)
call shells2contracted_gto(s_L, s_nprim, s_center, s_coef, s_alpha, &
    nprim, center, power, istart, coef, alpha)
n = size(nprim)
print "(a)", "----------------------------------------------------------"
print "(a)", "Center     Atomic              Coordinates (a.u.)"
print "(a)", "Number     Number             X           Y           Z"
print "(a)", "----------------------------------------------------------"
do i = 1, size(atno)
    print "(i4, i11, '       ', 3f12.6)", i, atno(i), xyz(:, i)
end do
print "(a)", "----------------------------------------------------------"
print *, "Nelec =", Nelec
print *, "DOFs  =", n
if (n > 120) call stop_error("Would need too much memory.")
m = n*(n+1)/2
allocate(S(n, n), T(n, n), V(n, n))
allocate(int2(m*(m+1)/2))
allocate(lpower(n), mpower(n), npower(n), xcenter(n), ycenter(n), zcenter(n))
lpower = power(1, :)
mpower = power(2, :)
npower = power(3, :)
xcenter = center(1, :)
ycenter = center(2, :)
zcenter = center(3, :)
xatom = xyz(1, :)
yatom = xyz(2, :)
zatom = xyz(3, :)

print *, "Calculating S ..."
call getS(n, nprim, istart-1, xcenter, ycenter, zcenter, &
        lpower, mpower, npower, size(coef), coef, alpha, S)

print *, "Calculating T ..."
call getT(n, nprim, istart-1, xcenter, ycenter, zcenter, &
        lpower, mpower, npower, size(coef), coef, alpha, T)

print *, "Calculating V ..."
call getV(n, nprim, istart-1, xcenter, ycenter, zcenter, &
        lpower, mpower, npower, size(coef), coef, alpha, &
        size(atno), atno, xatom, yatom, zatom, V)

print *, "Calculating two particle integrals (", size(int2), ")..."
call getints2(nprim, istart, center, power, coef, alpha, int2)

end subroutine

end module


\ This is an adaption of the matrix multiplication benchmark for using
\ run-time code generation (inspired by lee&leone96)

\ @InProceedings{lee&leone96,
\   author = 	 {Peter Lee and Mark Leone},
\   title = 	 {Optimizing ML with Run-Time Code Generation},
\   crossref =	 {sigplan96},
\   pages =	 {137--148}
\ }
\ @Proceedings{sigplan96,
\   booktitle = 	 "SIGPLAN '96 Conference on Programming Language
\ 		  Design and Implementation",
\   title = 	 "SIGPLAN '96 Conference on Programming Language
\ 		  Design and Implementation",
\   year = 	 "1996",
\   key = 	 "PLDI '96"
\ }

\ The original version is in comments.
\ The results with Gforth on a Nekotech Mach2 (300MHz 21064a) are very nice:
\ original program:		 6.2s user time
\ with run-time code generation: 3.9s user time
\ NOTE: This version needs 160,000+ cells data space
\	and a lot of code space, too.

\ A classical benchmark of an O(n**3) algorithm; Matrix Multiplication
\
\ Part of the programs gathered by John Hennessy for the MIPS
\ RISC project at Stanford. Translated to forth by  Marty Fraeman,
\ Johns Hopkins University/Applied Physics Laboratory.

\ MM forth2c doesn't have it !
: mybounds  over + swap ;
: under+ ( a x b -- a+b x )
   rot + swap ;

1 cells constant cell

variable seed

: initiate-seed ( -- )  74755 seed ! ;
: random  ( -- n )  seed @ 1309 * 13849 + 65535 and dup seed ! ;

200 constant row-size
row-size cells constant row-byte-size

row-size row-size * constant mat-size
mat-size cells constant mat-byte-size

align create ima mat-byte-size allot
align create imb mat-byte-size allot
align create imr mat-byte-size allot

: initiate-matrix ( m[row-size][row-size] -- )
  mat-byte-size mybounds do
    random dup 120 / 120 * - 60 - i !
  cell +loop
;

: gen-innerproduct ( a[row][*] -- xt )
\ xt is of type ( b[*][column] -- n )
\ this would be a candidate for using ]] ... [[
 >r :noname r>
 0 POSTPONE literal POSTPONE SWAP
 row-size 0 do
   POSTPONE dup POSTPONE @
   dup @ POSTPONE literal POSTPONE * POSTPONE under+
   POSTPONE cell+ row-byte-size +
  loop
  drop
 POSTPONE drop POSTPONE ;
;

\ : innerproduct ( a[row][*] b[*][column] -- int)
\   0 row-size 0 do ( a b int )
\     >r over @ over @ * r> + >r
\     cell+ swap row-byte-size + swap
\     r>
\   loop
\   >r 2drop r>
\ ;

: mainx  ( -- )
  initiate-seed
  ima initiate-matrix
  imb initiate-matrix
  imr ima mat-byte-size mybounds do
   i gen-innerproduct swap
    imb row-byte-size mybounds do ( r xt )
      i 2 pick execute over ! cell+
    cell +loop
    nip \ !! forget the xt
  row-size cells +loop
  drop
;

: main 10 0 do mainx loop ;

\ : main  ( -- )
\   initiate-seed
\   ima initiate-matrix
\   imb initiate-matrix
\   imr ima mat-byte-size mybounds do
\     imb row-byte-size mybounds do
\       j i innerproduct over ! cell+
\     cell +loop
\   row-size cells +loop
\   drop
\ ;


      SUBROUTINE SROTM (N,DX,INCX,DY,INCY,DPARAM)

c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2006-06-07 SROTM  Krogh  Removed arithmetic ifs
C>> 1994-10-20 SROTM  Krogh  Changes to use M77CON
C>> 1994-04-29 SROTM  CLL Edited to make DP and SP codes similar.
C>> 1985-08-02 SROTM  Lawson  Initial code.
C
C     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
C
C     (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
C     (DY**T)
C
C     DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
C     LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
C     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     DFLAG=-1.E0     DFLAG=0.E0        DFLAG=1.E0     DFLAG=-2.E0
C
C       (DH11  DH12)    (1.E0  DH12)    (DH11  1.E0)    (1.E0  0.E0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.E0),   (-1.E0 DH22),   (0.E0  1.E0).
C     SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
C     -----------------------------------------------------------------
c--S replaces "?": ?ROTM
C     -----------------------------------------------------------------
      integer i, incx, incy, kx, ky, n, nsteps
      REAL             DFLAG,DH11,DH12,DH21,DH22, DX(*),DY(*),DPARAM(5)
      REAL             TWO, W,Z, ZERO
      parameter(ZERO= 0.0e0, TWO= 2.0e0)
C     -----------------------------------------------------------------
C
      DFLAG=DPARAM(1)
      IF ((N .LE. 0) .OR. (DFLAG+TWO .EQ. ZERO)) RETURN
      IF ((INCX .NE. INCY) .OR. (INCX .LT. 0)) THEN
        KX=1
        KY=1
        IF(INCX .LT. 0) KX=1+(1-N)*INCX
        IF(INCY .LT. 0) KY=1+(1-N)*INCY
C
        IF (DFLAG .EQ. 0.E0) THEN
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DO 10 I=1,N
            W=DX(KX)
            Z=DY(KY)
            DX(KX)=W+Z*DH12
            DY(KY)=W*DH21+Z
            KX=KX+INCX
            KY=KY+INCY
 10       CONTINUE
        ELSE IF (DFLAG .GT. 0.E0) then
          DH11=DPARAM(2)
          DH22=DPARAM(5)
          DO 20 I=1,N
            W=DX(KX)
            Z=DY(KY)
            DX(KX)=W*DH11+Z
            DY(KY)=-W+DH22*Z
            KX=KX+INCX
            KY=KY+INCY
 20      CONTINUE
        ELSE
          DH11=DPARAM(2)
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DH22=DPARAM(5)
          DO 30 I=1,N
            W=DX(KX)
            Z=DY(KY)
            DX(KX)=W*DH11+Z*DH12
            DY(KY)=W*DH21+Z*DH22
            KX=KX+INCX
            KY=KY+INCY
 30       CONTINUE
        END IF
      ELSE
        NSTEPS=N*INCX
        IF (DFLAG .EQ. 0.E0) THEN
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DO 40 I=1,NSTEPS,INCX
            W=DX(I)
            Z=DY(I)
            DX(I)=W+Z*DH12
            DY(I)=W*DH21+Z
 40       CONTINUE
        ELSE IF (DFLAG .GT. 0.E0) THEN
          DH11=DPARAM(2)
          DH22=DPARAM(5)
          DO 50 I=1,NSTEPS,INCX
            W=DX(I)
            Z=DY(I)
            DX(I)=W*DH11+Z
            DY(I)=-W+DH22*Z
 50       CONTINUE
        ELSE
          DH11=DPARAM(2)
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DH22=DPARAM(5)
          DO 60 I=1,NSTEPS,INCX
            W=DX(I)
            Z=DY(I)
            DX(I)=W*DH11+Z*DH12
            DY(I)=W*DH21+Z*DH22
 60       CONTINUE
        END IF
      END IF
      RETURN
      END