************************************************************************
*
*     Subroutine MATCALC                             Called by: MLELOAD
*
*     calculate XTX and invert
*
*     local vars
*     ----------
*     XT      transpose of XLCAL
*     XTX     product of XT and the original matrix XLCAL
*
************************************************************************
      SUBROUTINE MATCALC(NPAR,NOBSC,XLCAL,XTXINV,NOBSCI)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NPAR,NOBSC,NOBSCI
      DOUBLE PRECISION XLCAL(NOBSCI,*),XTXINV(MAXPARMS,*)
*
*     local vars
*
      INTEGER*4 I,K,L
      DOUBLE PRECISION XT(MAXPARMS,NOBSCI),XTX(MAXPARMS,MAXPARMS)
*
*     transpose XLCAL to obtain XT
*
      DO 20 I=1,NOBSC
         DO 10 K=1,NPAR
            XT(K,I) = XLCAL(I,K)
 10      CONTINUE
 20   CONTINUE
*
*     multiply XT and XLCAL to obtain XTX; initialize XTXINV
*
      DO 50 I=1,NPAR
         DO 40 K=1,NPAR
            XTX(I,K) = 0.D0
            DO 30 L=1,NOBSC
                XTX(I,K) =  XTX(I,K) + XT(I,L)*XLCAL(L,K)
 30         CONTINUE
            XTXINV(I,K) = XTX(I,K)
 40      CONTINUE
 50   CONTINUE
*
*     factor and invert matrix XTX producing XTXINV
*
      CALL FACINV(XTXINV,MAXPARMS,NPAR)

      RETURN
      END


submodule(euler_interface_m) euler_prob_0038_m
    implicit none

contains

    module character(len=20) function euler0038()
        write (euler0038, "(i20)") ans()
    end function euler0038

    integer(int64) function ans()
        integer(int64), allocatable :: common_arr(:)
        integer(int64) :: i, j, tmp

        outer: do i = 2_int64, 10000_int64
            j = 1_int64; tmp = 0_int64

            inner: do
                if (tmp /= 0) then
                    if (digs_of_int(tmp) > 9_int64) then
                        cycle outer
                    end if
                end if

                if (is_pandigital(tmp)) then
                    call append(common_arr, tmp)
                end if

                tmp = i*j + tmp*10_int64**digs_of_int(i*j)
                j = j + 1_int64
            end do inner
        end do outer

        ans = maxval(common_arr, dim=1)
    end function ans
end submodule euler_prob_0038_m


      program test12

!================================================
! Test spaghettifier
!================================================

      implicit none

      integer a, b, c, n, m, k
      real r

      b=5
      a=2
      c=3

      do j=1,10,1
         b = 5
         a = 8
         do i=1,10,1
            n = a*i + b
            m = b*i + j
            k = k + n * m
         enddo
         a = b + k
      end do

      if (a.LT.b) then
       b = 5
       a = 17
      else
       b = 7
       a = 89
      end if

      do while (a .LT. b)
         r = a*r
         a = a+9
      end do

      stop
      end


      subroutine pot(x,v,ddv)
      implicit real*8(a-h,o-z)

      ipot = 2

      if (ipot == 0) then
        ep = 0.0
        v = x**2/2d0 + ep*x**4/4.0
        ddv = 1d0 + 3.0*x**2*ep

      elseif(ipot == 1) then

        eta = 1.3544d0
        v = 1d0/16d0/eta*x**4-0.5d0*x**2
        ddv = 3d0/4d0/eta*x**2-1d0
      elseif(ipot == 2) then

        D = 16d0
!        a = 1.3624d0
        a = 1d0

        v = D/cosh(a*x)**2
        ddv = 6d0*D*a**2*sinh(a*x)**2/cosh(a*x)**4-2d0*D*a**2/cosh(a*x)**2
      endif

      return
      end subroutine

      subroutine ham(c,nb,q,p,s,dc)

      use cdat
      implicit real (kind = 8) (a-h,o-z)

      integer*4, intent(in) :: nb
      complex*16, dimension(nb), intent(in) :: c
      real*8, intent(in), dimension(nb) :: q,p,s

      complex*16,intent(out) :: dc(nb)

      real*8 :: v,dv,ddv

      complex*16, dimension(nb,nb) :: h,mat
      real*8 :: aux(nb,nb)

      complex*16 :: z,z0,d0,d1,d2,b(nb)
      real*8 b1(nb,2)

      call multi(nb,q,p,s,mat)

      anrm = dsqrt(dsqrt(al/pi))
!      eta = 1.3544d0

      do j=1,nb
        do k=1,nb
          dq = q(k)-q(j)
          z = dq/2d0
          z0 = exp(-al*dq**2/4d0)
          d0 = al/(4d0*am)*(1d0-al/2d0*dq**2)
          y = (q(j)+q(k))/2d0

! --- local harmonic approximation
          call pot(y,v,ddv)
          d1 = v + ddv/(4d0*al)

! --- analytical potential integration for double-well
!          d1 = 1d0/(16d0*eta)*(y**4 + 3d0*y**2/al + 3d0/(4d0*al**2)) -
!          0.5d0*(y**2+1d0/(2d0*al))

          d2 = im*p(k)*al/(2d0*am)*dq
          h(j,k) = z0*(d0+d1+d2)
        enddo
      enddo

      b = matmul(h,c)

      do i=1,nb
        b1(i,1) = real(b(i))
        b1(i,2) = imag(b(i))
      enddo

!      call inverse(mat,mativs,nb)

!-------save the overlap matrix-----------
      do i=1,nb
      do j=1,nb
        aux(i,j) = real(mat(i,j))
      enddo
      enddo

      call dposv('U', nb, 2, aux, nb, b1, nb, INFO)
      if(INFO .ne. 0) then
        write(*,*) 'dC/dt: Matrix fails, INFO =',INFO
        stop
      endif
!------compute increment dc------------
      do j=1,nb
        dc(j) = -im*(b1(j,1)+im*b1(j,2))
      enddo

      return
      end subroutine


c     comment section.
c
c     fm009
c
c         this routine tests arithmetic assignment statements of the
c     form
c             integer variable = arithmetic expression
c     where the arithmetic expression is formed with the arithmetic
c     operator +, integer constants and positive integer variables.
c     some of the tests use parentheses to group elements in the
c     arithmetic expression.
c
c         there are tests where the arithmetic expression contains
c            (1)  two integer variables,
c            (2)  two integer variables and one integer constant,
c            (3)  two integer variables and one integer constant with
c                   parentheses to group elements.
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 10.1, arithmetic assignment statements
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c     test section
c
c         arithmetic assignment statement
c
c     test 235 through test 243 contain two positive integer variables
c     and operator + in arithmetic expression.
c
 2351 continue
      ivtnum = 235
c
c      ****  test 235  ****
c
      if (iczero) 32350, 2350, 32350
 2350 continue
      ivon01 = 2
      ivon02 = 3
      ivcomp = ivon01 + ivon02
      go to 42350
32350 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42350, 2361, 42350
42350 if (ivcomp - 5) 22350,12350,22350
12350 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2361
22350 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2361 continue
      ivtnum = 236
c
c      ****  test 236  ****
c
      if (iczero) 32360, 2360, 32360
 2360 continue
      ivon01 = 2
      ivon02 = 3
      ivcomp = ivon02 + ivon01
      go to 42360
32360 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42360, 2371, 42360
42360 if (ivcomp - 5) 22360, 12360, 22360
12360 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2371
22360 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2371 continue
      ivtnum = 237
c
c      ****  test 237  ****
c
      if (iczero) 32370, 2370, 32370
 2370 continue
      ivon01 = 51
      ivon02 = 52
      ivcomp = ivon01 + ivon02
      go to 42370
32370 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42370, 2381, 42370
42370 if (ivcomp - 103) 22370, 12370, 22370
12370 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2381
22370 ivfail = ivfail + 1
      ivcorr = 103
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2381 continue
      ivtnum = 238
c
c      ****  test  238 ****
c
      if (iczero) 32380, 2380, 32380
 2380 continue
      ivon01 = 189
      ivon02 = 676
      ivcomp = ivon01 + ivon02
      go to 42380
32380 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42380, 2391, 42380
42380 if (ivcomp - 865) 22380, 12380, 22380
12380 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2391
22380 ivfail = ivfail + 1
      ivcorr = 865
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2391 continue
      ivtnum = 239
c
c      ****  test 239  ****
c
      if (iczero) 32390, 2390, 32390
 2390 continue
      ivon01 = 1358
      ivon02 = 8001
      ivcomp = ivon01 + ivon02
      go to 42390
32390 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42390, 2401, 42390
42390 if (ivcomp - 9359) 22390, 12390, 22390
12390 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2401
22390 ivfail = ivfail + 1
      ivcorr = 9359
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2401 continue
      ivtnum = 240
c
c      ****  test 240  ****
c
      if (iczero) 32400, 2400, 32400
 2400 continue
      ivon01 = 1358
      ivon02 = 8001
      ivcomp = ivon02 + ivon01
      go to 42400
32400 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42400, 2411, 42400
42400 if (ivcomp - 9359) 22400, 12400, 22400
12400 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2411
22400 ivfail = ivfail + 1
      ivcorr = 9359
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2411 continue
      ivtnum = 241
c
c      ****  test 241  ****
c
      if (iczero) 32410, 2410, 32410
 2410 continue
      ivon01 = 11112
      ivon02 = 10001
      ivcomp = ivon01 + ivon02
      go to 42410
32410 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42410, 2421, 42410
42410 if (ivcomp - 21113) 22410, 12410, 22410
12410 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2421
22410 ivfail = ivfail + 1
      ivcorr = 21113
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2421 continue
      ivtnum = 242
c
c      **** test 242  ****
c
      if (iczero) 32420, 2420, 32420
 2420 continue
      ivon01 = 189
      ivon02 = 9876
      ivcomp = ivon01 + ivon02
      go to 42420
32420 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42420, 2431, 42420
42420 if (ivcomp - 10065) 22420, 12420, 22420
12420 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2431
22420 ivfail = ivfail + 1
      ivcorr = 10065
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2431 continue
      ivtnum = 243
c
c      **** test 243  ****
c         requires 32767
c
      if (iczero) 32430, 2430, 32430
 2430 continue
      ivon01 = 16383
      ivon02 = 16384
      ivcomp = ivon01 + ivon02
      go to 42430
32430 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42430, 2441, 42430
42430 if (ivcomp - 32767) 22430, 12430, 22430
12430 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2441
22430 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 244 through test 250 contain two positive integer variables,
c     one integer constant, and operator + in arithmetic expression.
c
 2441 continue
      ivtnum = 244
c
c      ****  test 244  ****
c
      if (iczero) 32440, 2440, 32440
 2440 continue
      ivon01 = 2
      ivon02 = 3
      ivcomp = ivon01 + ivon02 + 4
      go to 42440
32440 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42440, 2451, 42440
42440 if (ivcomp - 9) 22440, 12440, 22440
12440 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2451
22440 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2451 continue
      ivtnum = 245
c
c      ****  test 245  ****
c
      if (iczero) 32450, 2450, 32450
 2450 continue
      ivon01 = 2
      ivon03 = 4
      ivcomp = ivon01 +3 + ivon03
      go to 42450
32450 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42450, 2461, 42450
42450 if (ivcomp - 9) 22450, 12450, 22450
12450 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2461
22450 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2461 continue
      ivtnum = 246
c
c      ****  test 246  ****
c
      if (iczero) 32460, 2460, 32460
 2460 continue
      ivon02 = 3
      ivon03 = 4
      ivcomp = 2 + ivon02 + ivon03
      go to 42460
32460 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42460, 2471, 42460
42460 if (ivcomp - 9) 22460, 12460, 22460
12460 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2471
22460 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2471 continue
      ivtnum = 247
c
c      ****  test 247  ****
c
      if (iczero) 32470, 2470, 32470
 2470 continue
      ivon01 = 51
      ivon03 = 53
      ivcomp = ivon01 +52 + ivon03
      go to 42470
32470 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42470, 2481, 42470
42470 if (ivcomp - 156) 22470, 12470, 22470
12470 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2481
22470 ivfail = ivfail + 1
      ivcorr = 156
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2481 continue
      ivtnum = 248
c
c      ****  test 248  ****
c
      if (iczero) 32480, 2480, 32480
 2480 continue
      ivon02 = 676
      ivon03 = 101
      ivcomp = 189 + ivon02 + ivon03
      go to 42480
32480 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42480, 2491, 42480
42480 if (ivcomp - 966) 22480, 12480, 22480
12480 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2491
22480 ivfail = ivfail + 1
      ivcorr = 966
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2491 continue
      ivtnum = 249
c
c      ****  test 249  ****
c
      if (iczero) 32490, 2490, 32490
 2490 continue
      ivon01 = 1358
      ivon02 = 8001
      ivcomp = ivon01 + ivon02 + 2189
      go to 42490
32490 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42490, 2501, 42490
42490 if (ivcomp - 11548) 22490, 12490, 22490
12490 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2501
22490 ivfail = ivfail + 1
      ivcorr = 11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2501 continue
      ivtnum = 250
c
c      ****  test 250  ****
c         requires 32767
c
      if (iczero) 32500, 2500, 32500
 2500 continue
      ivon01 = 16383
      ivon03 = 4
      ivcomp = ivon01 + 16380 + ivon03
      go to 42500
32500 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42500, 2511, 42500
42500 if (ivcomp - 32767) 22500,12500,22500
12500 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2511
22500 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 251 through test 264 contain two positive integer variables,
c     one integer constant, and operator + in arithmetic expression.
c     parentheses are used to group elements.  the results are the same
c     as tests 244 through 250.
c
 2511 continue
      ivtnum = 251
c
c      ****  test 251  ****
c
      if (iczero) 32510, 2510, 32510
 2510 continue
      ivon01 = 2
      ivon02 = 3
      ivcomp = (ivon01 + ivon02) + 4
      go to 42510
32510 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42510, 2521, 42510
42510 if (ivcomp - 9) 22510,12510,22510
12510 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2521
22510 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2521 continue
      ivtnum = 252
c
c      ****  test 252  ****
c
      if (iczero) 32520, 2520, 32520
 2520 continue
      ivon02 = 3
      ivon03 = 4
      ivcomp = 2 + (ivon02 + ivon03)
      go to 42520
32520 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42520, 2531, 42520
42520 if (ivcomp - 9) 22520,12520,22520
12520 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2531
22520 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2531 continue
      ivtnum = 253
c
c      **** test 253  ****
c
      if (iczero) 32530, 2530, 32530
 2530 continue
      ivon02 =3
      ivon03 =4
      ivcomp = (2+ivon02)+ivon03
      go to 42530
32530 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42530, 2541, 42530
42530 if (ivcomp -9) 22530,12530,22530
12530 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2541
22530 ivfail = ivfail + 1
      ivcorr =9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2541 continue
      ivtnum = 254
c
c      ****  test 254  ****
c
      if (iczero) 32540, 2540, 32540
 2540 continue
      ivon01 = 2
      ivon02 = 3
      ivcomp = ivon01 + (ivon02 + 4)
      go to 42540
32540 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42540, 2551, 42540
42540 if (ivcomp-9)22540,12540,22540
12540 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2551
22540 ivfail = ivfail + 1
      ivcorr=9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2551 continue
      ivtnum = 255
c
c      ****  test 255  ****
c
      if (iczero) 32550, 2550, 32550
 2550 continue
      ivon01 = 2
      ivon03 = 4
      ivcomp = ivon01 +(3+ivon03)
      go to 42550
32550 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42550, 2561, 42550
42550 if (ivcomp-9)22550,12550,22550
12550 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2561
22550 ivfail = ivfail + 1
      ivcorr =9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2561 continue
      ivtnum = 256
c
c      ****  test 256  ****
c
      if (iczero) 32560, 2560, 32560
 2560 continue
      ivon01 = 2
      ivon03 = 4
      ivcomp =(ivon01+3)+ivon03
      go to 42560
32560 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42560, 2571, 42560
42560 if (ivcomp-9) 22560,12560,22560
12560 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2571
22560 ivfail = ivfail + 1
      ivcorr =9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2571 continue
      ivtnum = 257
c
c      ****  test 257  ****
c
      if (iczero) 32570, 2570, 32570
 2570 continue
      ivon01 = 51
      ivon03 = 53
      ivcomp=ivon01+(52+ivon03)
      go to 42570
32570 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42570, 2581, 42570
42570 if (ivcomp -156) 22570,12570,22570
12570 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2581
22570 ivfail = ivfail + 1
      ivcorr = 156
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2581 continue
      ivtnum = 258
c
c      ****  test 258  ****
c
      if (iczero) 32580, 2580, 32580
 2580 continue
      ivon01 = 51
      ivon03 = 53
      ivcomp =(ivon01+52)+ivon03
      go to 42580
32580 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42580, 2591, 42580
42580 if (ivcomp-156) 22580,12580,22580
12580 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2591
22580 ivfail = ivfail + 1
      ivcorr = 156
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2591 continue
      ivtnum = 259
c
c      ****  test 259  ****
c
      if (iczero) 32590, 2590, 32590
 2590 continue
      ivon02 = 676
      ivon03 = 101
      ivcomp = 189+(ivon02+ivon03)
      go to 42590
32590 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42590, 2601, 42590
42590 if (ivcomp -966) 22590,12590,22590
12590 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2601
22590 ivfail = ivfail + 1
      ivcorr =966
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2601 continue
      ivtnum = 260
c
c      ****  test 260  ****
c
      if (iczero) 32600, 2600, 32600
 2600 continue
      ivon02 = 676
      ivon03 = 101
      ivcomp = (189 + ivon02) + ivon03
      go to 42600
32600 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42600, 2611, 42600
42600 if (ivcomp-966) 22600,12600,22600
12600 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2611
22600 ivfail = ivfail + 1
      ivcorr=966
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2611 continue
      ivtnum = 261
c
c      ****  test 261  ****
c
      if (iczero) 32610, 2610, 32610
 2610 continue
      ivon01 = 1358
      ivon02 = 8001
      ivcomp = ivon01 + (ivon02 + 2189)
      go to 42610
32610 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42610, 2621, 42610
42610 if (ivcomp-11548) 22610,12610,22610
12610 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2621
22610 ivfail = ivfail + 1
      ivcorr=11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2621 continue
      ivtnum = 262
c
c      ****  test 262  ****
c
      if (iczero) 32620, 2620, 32620
 2620 continue
      ivon01 = 1358
      ivon02 = 8001
      ivcomp =(ivon01+ivon02)+2189
      go to 42620
32620 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42620, 2631, 42620
42620 if (ivcomp-11548) 22620,12620,22620
12620 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2631
22620 ivfail = ivfail + 1
      ivcorr=11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2631 continue
      ivtnum = 263
c
c      ****  test 263  ****
c         requires 32767
c
      if (iczero) 32630, 2630, 32630
 2630 continue
      ivon01 = 16383
      ivon03 = 16380
      ivcomp = ivon01 + (4+ivon03)
      go to 42630
32630 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42630, 2641, 42630
42630 if (ivcomp-32767) 22630,12630,22630
12630 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2641
22630 ivfail = ivfail + 1
      ivcorr =32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2641 continue
      ivtnum = 264
c
c      ****  test 264  ****
c         requires 32767
c
      if (iczero) 32640, 2640, 32640
 2640 continue
      ivon01 = 16383
      ivon02 = 16380
      ivcomp = (ivon01+ivon02) +4
      go to 42640
32640 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42640, 2651, 42640
42640 if (ivcomp - 32767) 22640,12640,22640
12640 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2651
22640 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2651 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm009)
      end


SUBROUTINE AVERAGE(ARR, SIZE, VALUE)
    IMPLICIT NONE
    INTEGER:: SIZE, COUNT
    REAL, INTENT(OUT):: VALUE
    REAL, DIMENSION(SIZE):: ARR
    COUNT = 1
    VALUE = 0
!f2py intent(in) size
!f2py depend(size) arr

100 IF (COUNT.LE.SIZE) THEN
        VALUE = VALUE + ARR(COUNT)
        COUNT = COUNT + 1
        GOTO 100
    ENDIF
    VALUE = VALUE / SIZE
    RETURN
END SUBROUTINE AVERAGE


function sum_array(size,a) result(ret)
  implicit none
  integer :: size
  integer, dimension(size) :: a
  integer :: i
  integer :: ret

  ret = 0

  do i=1,size
    ret = ret + a(i)
  end do

end function sum_array


module assert

use, intrinsic:: iso_c_binding, only: sp=>c_float, dp=>c_double
use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
use, intrinsic:: ieee_arithmetic

implicit none (type, external)

interface isclose
procedure isclose_r, isclose_c
end interface isclose

private

integer,parameter :: wp = dp

public :: wp, isclose, assert_isclose

contains

elemental logical function isclose_r(actual, desired, rtol, atol, equal_nan) result(isclose)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
!
!  rtol overrides atol when both are specified
!
! https://www.python.org/dev/peps/pep-0485/#proposed-implementation
! https://github.com/PythonCHB/close_pep/blob/master/is_close.py

real(wp), intent(in) :: actual, desired
real(wp), intent(in), optional :: rtol, atol
logical, intent(in), optional :: equal_nan

real(wp) :: r,a
logical :: n
! this is appropriate INSTEAD OF merge(), since non present values aren't defined.
r = 1e-5_wp
a = 0
n = .false.
if (present(rtol)) r = rtol
if (present(atol)) a = atol
if (present(equal_nan)) n = equal_nan

!print*,r,a,n,actual,desired

!--- sanity check
if ((r < 0).or.(a < 0)) error stop 'invalid tolerance parameter(s)'
!--- equal nan
isclose = n.and.(ieee_is_nan(actual).and.ieee_is_nan(desired))
if (isclose) return
!--- Inf /= Inf, unequal NaN
if (.not.ieee_is_finite(actual) .or. .not.ieee_is_finite(desired)) return
!--- floating point closeness check
isclose = abs(actual-desired) <= max(r * max(abs(actual), abs(desired)), a)

end function isclose_r

elemental logical function isclose_c(actual, desired, rtol, atol) result(isclose)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
!
!  rtol overrides atol when both are specified
!
! https://www.python.org/dev/peps/pep-0485/#proposed-implementation
! https://github.com/PythonCHB/close_pep/blob/master/is_close.py

complex(wp), intent(in) :: actual, desired
real(wp), intent(in), optional :: rtol, atol

real(wp) :: r,a
! this is appropriate INSTEAD OF merge(), since non present values aren't defined.
r = 1e-5_wp
a = 0
if (present(rtol)) r = rtol
if (present(atol)) a = atol

!print*,r,a,n,actual,desired

!--- sanity check
if ((abs(r) < 0).or.(abs(a) < 0)) error stop 'impossible rel or abs tolerance'
!--- floating point closeness check
isclose = abs(actual-desired) <= max(r * max(abs(actual), abs(desired)), a)

end function isclose_c

impure elemental subroutine assert_isclose(actual, desired, rtol, atol, equal_nan, err_msg)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
! err_msg: message to print on mismatch
!
! rtol overrides atol when both are specified

real(wp), intent(in) :: actual, desired
real(wp), intent(in), optional :: rtol, atol
logical, intent(in), optional :: equal_nan
character(*), intent(in), optional :: err_msg

character(:), allocatable :: msg

if (isclose(actual,desired,rtol,atol,equal_nan)) return

msg = 'MISMATCH'
if (present(err_msg)) msg = err_msg

write(stderr,*) msg,': actual',actual,'desired',desired

error stop

end subroutine assert_isclose

end module assert


MODULE FUN_xyPERPCCW
!!#### PURPOSE
!! Construct a perpendicular vector by 90 degrees
!! Counter-Clockwise (CCW) rotation.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyPERPCCW_V
 MODULE PROCEDURE xyPERPCCW_V_Rsp
 MODULE PROCEDURE xyPERPCCW_V_Rdp
END INTERFACE

INTERFACE xyPERPCCW_U
 MODULE PROCEDURE xyPERPCCW_U_Rsp
 MODULE PROCEDURE xyPERPCCW_U_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyPERPCCW_V
PUBLIC :: xyPERPCCW_U

CONTAINS

PURE FUNCTION xyPERPCCW_V_Rsp( V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyPERPCCW_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyPERPCCW_V.f90.bdy"
!!--end--
ENDFUNCTION

PURE FUNCTION xyPERPCCW_V_Rdp( V ) RESULT(xyV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyPERPCCW_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyPERPCCW_V.f90.bdy"
!!--end--
ENDFUNCTION

PURE FUNCTION xyPERPCCW_U_Rsp( U ) RESULT(xyU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyPERPCCW_U.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyPERPCCW_U.f90.bdy"
!!--end--
ENDFUNCTION

PURE FUNCTION xyPERPCCW_U_Rdp( U ) RESULT(xyU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyPERPCCW_U.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyPERPCCW_U.f90.bdy"
!!--end--
ENDFUNCTION

END MODULE


*> \brief \b ICMAX1 finds the index of the first vector element of maximum absolute value.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ICMAX1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       INTEGER          FUNCTION ICMAX1( N, CX, INCX )
*
*       .. Scalar Arguments ..
*       INTEGER            INCX, N
*       ..
*       .. Array Arguments ..
*       COMPLEX            CX( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ICMAX1 finds the index of the first vector element of maximum absolute value.
*>
*> Based on ICAMAX from Level 1 BLAS.
*> The change is to use the 'genuine' absolute value.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of elements in the vector CX.
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*>          CX is COMPLEX array, dimension (N)
*>          The vector CX. The ICMAX1 function returns the index of its first
*>          element of maximum absolute value.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>          The spacing between successive values of CX.  INCX >= 1.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date February 2014
*
*> \ingroup complexOTHERauxiliary
*
*> \par Contributors:
*  ==================
*>
*> Nick Higham for use with CLACON.
*
*  =====================================================================
      INTEGER FUNCTION ICMAX1( N, CX, INCX )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     February 2014
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
*     ..
*     .. Array Arguments ..
      COMPLEX            CX(*)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL               SMAX
      INTEGER            I, IX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      ICMAX1 = 0
      IF (N.LT.1 .OR. INCX.LE.0) RETURN
      ICMAX1 = 1
      IF (N.EQ.1) RETURN
      IF (INCX.EQ.1) THEN
*
*        code for increment equal to 1
*
         SMAX = ABS(CX(1))
         DO I = 2,N
            IF (ABS(CX(I)).GT.SMAX) THEN
               ICMAX1 = I
               SMAX = ABS(CX(I))
            END IF
         END DO
      ELSE
*
*        code for increment not equal to 1
*
         IX = 1
         SMAX = ABS(CX(1))
         IX = IX + INCX
         DO I = 2,N
            IF (ABS(CX(IX)).GT.SMAX) THEN
               ICMAX1 = I
               SMAX = ABS(CX(IX))
            END IF
            IX = IX + INCX
         END DO
      END IF
      RETURN
*
*     End of ICMAX1
*
      END


PROGRAM array_test
  IMPLICIT NONE
  !Array runs from 1->10
  !Different to most other languages
  !that run 0->9
  INTEGER, DIMENSION(10) :: array
  INTEGER :: i

  !Can use an IMPLIED DO LOOP
  !to set up this array (c.f. linspace etc.)
  array = [(i,i=1,SIZE(array))]

  !Can print whole arrays although large
  !arrays are hard to read
  PRINT *, array

END PROGRAM array_test


      SUBROUTINE SSCAL(N,A,X,INCX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 SSCAL  Krogh   Declared all vars.
C>> 1994-10-20 SSCAL  Krogh  Changes to use M77CON
C>> 1985-08-02 SSCAL  Lawson  Initial code.
c--S replaces "?": ?SCAL
C
C     REPLACE X BY  A*X.
C     FOR I = 0 TO N-1, REPLACE X(1+I*INCX) WITH  A * X(1+I*INCX)
C
      INTEGER N, INCX, NS, I, M, MP1
      REAL             A,X(*)
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I = 1,NS,INCX
          X(I) = A*X(I)
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        X(I) = A*X(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        X(I) = A*X(I)
        X(I + 1) = A*X(I + 1)
        X(I + 2) = A*X(I + 2)
        X(I + 3) = A*X(I + 3)
        X(I + 4) = A*X(I + 4)
   50 CONTINUE
      RETURN
      END


program alloctest
  integer, allocatable :: a(:, :)
  integer :: i, j

  allocate(a(3, 4))

  do i = 1, 3
    do j = 1, 4

      a(i, j) = i * j
    end do
  end do
  print *, a
end program alloctest


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     4/97
!
!     a program for testing all theta derivative subroutines
!     vtses, vtsec, vtsgs, vtsgc
!
!
!     (1) first set a valid vector field (v, w) in terms of x, y, z
!         cartesian coordinates
!
!     (2) analytically compute (vt, wt) from (1)
!
!     (3) compute (vt, wt) using vtses, vtsec, vtsgs, vtsgc and compare with (2)
!
program tvts

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: bi
    real(wp) :: br
    real(wp) :: ci
    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: cr
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: dxdt
    real(wp) :: dydt
    real(wp) :: dzdt
    real(wp) :: emz
    real(wp) :: err2v
    real(wp) :: err2w
    real(wp) :: ex
    real(wp) :: ey
    real(wp) :: ez
    integer(ip) :: i
    integer(ip) :: icase
    integer(ip) :: ier
    integer(ip) :: ierror
    integer(ip) :: ityp
    integer(ip) :: j
    integer(ip) :: k
    integer(ip) :: ldwork
    integer(ip) :: lldwork
    integer(ip) :: lleng
    integer(ip) :: llsav
    integer(ip) :: lsave
    integer(ip) :: lwork
    integer(ip) :: nlat
    integer(ip) :: nlon
    integer(ip) :: nnlat
    integer(ip) :: nnlon
    integer(ip) :: nnt
    integer(ip) :: nt
    real(wp) :: phi
    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta
    real(wp) :: gaussian_latitudes
    real(wp) :: v
    real(wp) :: vt
    real(wp) :: vtsav
    real(wp) :: w
    real(wp) :: work
    real(wp) :: wsave
    real(wp) :: wt
    real(wp) :: wtsav
    real(wp) :: x
    real(wp) :: y
    real(wp) :: z
    !
    !     set dimensions with parameter statements
    !
    parameter(nnlat= 25, nnlon= 19, nnt = 3)
    parameter (lleng= 5*nnlat*nnlat*nnlon, llsav= 5*nnlat*nnlat*nnlon)
    dimension work(lleng), wsave(llsav)
    parameter (lldwork = 4*nnlat*nnlat)
    real dwork(lldwork)
    dimension br(nnlat, nnlat, nnt), bi(nnlat, nnlat, nnt)
    dimension cr(nnlat, nnlat, nnt), ci(nnlat, nnlat, nnt)
    dimension gaussian_latitudes(nnlat), dwts(nnlat)
    dimension v(nnlat, nnlon, nnt), w(nnlat, nnlon, nnt)
    dimension vt(nnlat, nnlon, nnt), wt(nnlat, nnlon, nnt)
    dimension vtsav(nnlat, nnlon, nnt), wtsav(nnlat, nnlon, nnt)
    real dtheta, dwts

    write (stdout, '(/a/)') '     tvts *** TEST RUN *** '

    !
    !     set dimension variables
    !
    nlat = nnlat
    nlon = nnlon
    lwork = lleng
    lsave = llsav
    nt = nnt
    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")
    ityp = 0
    !
    !     set equally spaced colatitude and longitude increments
    !
    dphi = (pi+pi)/nlon
    dlat = pi/(nlat-1)
    !
    !     compute nlat gaussian points in thetag
    !
    ldwork = lldwork
    call compute_gaussian_latitudes_and_weights(nlat, gaussian_latitudes, dwts, ier)

    call name("compute_gaussian_latitudes_and_weights")
    call iout(ier, " ier")
    call vecout(gaussian_latitudes, "thtg", nlat)
    !
    !     test all theta derivative subroutines
    !
    do icase=1, 4
        !
        !     icase=1 test vtsec
        !     icase=2 test vtses
        !     icase=3 test vtsgc
        !     icase=4 test vtsgs
        !
        call name("****")
        call name("****")
        call iout(icase, "icas")
        !
        !
        !     set vector field v, w and compute theta derivatives in (vtsav, wtsav)
        !
        do k=1, nt
            do j=1, nlon
                phi = (j-1)*dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (icase)
                        case(3:4)
                            theta = gaussian_latitudes(i)
                        case default
                            theta = real(i - 1, kind=wp)*dlat
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                       !
                       !    set x, y, z and their theta derivatives at colatitude theta and longitude p
                       !
                    x = sint*cosp
                    dxdt = cost*cosp
                    y = sint*sinp
                    dydt = cost*sinp
                    z = cost
                    dzdt = -sint
                    !
                    !     set (v, w) field corresponding to stream function
                    !     S = exp(y)+exp(-z) and velocity potential function
                    !     P = exp(x)+exp(z)
                    !
                    ex = exp(x)
                    ey = exp(y)
                    ez = exp(z)
                    emz = exp(-z)
                    w(i, j, k) =-ex*sinp+emz*sint+ey*cost*sinp
                    v(i, j, k) =-ey*cosp-ez*sint+ex*cost*cosp
                    !
                    !     set theta derivatives differentiating w, v above
                    !
                    wtsav(i, j, k) = -ex*dxdt*sinp+emz*(-dzdt*sint+cost) &
                        +ey*sinp*(dydt*cost-sint)
                    vtsav(i, j, k) = -ey*dydt*cosp-ez*(dzdt*sint+cost) &
                        +ex*cosp*(dxdt*cost-sint)
                end do
            end do
        end do

        select case (icase)
            case (1)

                call name("**ec")

                call vhaeci(nlat, nlon, wsave, ierror)
                call name("vhai")
                call iout(ierror, "ierr")

                call vhaec(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vha ")
                call iout(ierror, "ierr")

                !
                !     now compute theta derivatives of v, w
                !
                call vtseci(nlat, nlon, wsave, ierror)

                call name("vtsi")
                call iout(ierror, "ierr")

                call vtsec(nlat, nlon, ityp, nt, vt, wt, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vts ")
                call iout(ierror, "ierr")
            case (2)

                call name("**es")

                call vhaesi(nlat, nlon, wsave, ierror)
                call name("vhai")
                call iout(ierror, "ierr")

                call vhaes(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vha ")
                call iout(ierror, "ierr")

                call vtsesi(nlat, nlon, wsave, ierror)
                call name("vtsi")
                call iout(ierror, "ierr")

                call vtses(nlat, nlon, ityp, nt, vt, wt, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vts ")
                call iout(ierror, "ierr")
            case (3)

                call name("**gc")

                call name("vhgi")
                call iout(nlat, "nlat")

                call vhagci(nlat, nlon, wsave, ierror)
                call name("vhai")
                call iout(ierror, "ierr")

                call vhagc(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vha ")
                call iout(ierror, "ierr")

                !
                !     now synthesize v, w from br, bi, cr, ci and compare with original
                !
                call vtsgci(nlat, nlon, wsave, ierror)
                call name("vtsi")
                call iout(ierror, "ierr")

                call vtsgc(nlat, nlon, ityp, nt, vt, wt, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vts ")
                call iout(ierror, "ierr")
            case (4)

                call name("**gs")
                call vhagsi(nlat, nlon, wsave, ierror)
                call name("vhai")
                call iout(ierror, "ierr")

                call vhags(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vha ")
                call iout(ierror, "ierr")

                call vtsgsi(nlat, nlon, wsave, ierror)
                call name("vtsi")
                call iout(ierror, "ierr")

                call vtsgs(nlat, nlon, ityp, nt, vt, wt, nlat, nlon, br, bi, cr, ci, nlat, &
                    nlat, wsave, ierror)
                call name("vts ")
                call iout(ierror, "ierr")
        end select

        !
        !     compute "error" in vt, wt
        !
        err2v = norm2(vt- vtsav)
        err2w = norm2(wt - wtsav)
        !
        !     set and print least squares error in v, w
        !
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    !
    !     end of icase loop
    !
    end do

end program tvts


      SUBROUTINE tqli(d,e,n,np,z)
      INTEGER n,np
      REAL d(np),e(np),z(np,np)
CU    USES pythag
      INTEGER i,iter,k,l,m
      REAL b,c,dd,f,g,p,r,s,pythag
      do 11 i=2,n
        e(i-1)=e(i)
11    continue
      e(n)=0.
      do 15 l=1,n
        iter=0
1       do 12 m=l,n-1
          dd=abs(d(m))+abs(d(m+1))
          if (abs(e(m))+dd.eq.dd) goto 2
12      continue
        m=n
2       if(m.ne.l)then
          if(iter.eq.30)pause 'too many iterations in tqli'
          iter=iter+1
          g=(d(l+1)-d(l))/(2.*e(l))
          r=pythag(g,1.)
          g=d(m)-d(l)+e(l)/(g+sign(r,g))
          s=1.
          c=1.
          p=0.
          do 14 i=m-1,l,-1
            f=s*e(i)
            b=c*e(i)
            r=pythag(f,g)
            e(i+1)=r
            if(r.eq.0.)then
              d(i+1)=d(i+1)-p
              e(m)=0.
              goto 1
            endif
            s=f/r
            c=g/r
            g=d(i+1)-p
            r=(d(i)-g)*s+2.*c*b
            p=s*r
            d(i+1)=g+p
            g=c*r-b
C     Omit lines from here ...
            do 13 k=1,n
              f=z(k,i+1)
              z(k,i+1)=s*z(k,i)+c*f
              z(k,i)=c*z(k,i)-s*f
13          continue
C     ... to here when finding only eigenvalues.
14        continue
          d(l)=d(l)-p
          e(l)=g
          e(m)=0.
          goto 1
        endif
15    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/tqli.for


  subroutine kram3(aa,b,x)
  real aa(3,3), a(3,3),b(3),x(3),d,det
  call detr3(aa,DET)
  do i=1,3
     a=aa
     do J=1,3
        a(j,i)=b(j)
     end do
     call detr3(a,d)
     x(i)=d/det
  end do
  return
  end

     SUBROUTINE DETR3(A,D)
     REAL A(3,3),d
     INTEGER num(3,3,3), i1,i2,i3
     num=0
     num(1,2,3)=1
     num(1,3,2)=-1
     num(2,1,3)=-1
     num(2,3,1)=1
     num(3,1,2)=1
     num(3,2,1)=-1
     D=0.
     DO I1=1,3
        DO I2=1,3
           DO I3=1,3
              D=D+A(1,I1)*A(2,I2)*A(3,I3)*num(i1,i2,i3)
           end do
        end do
     end do
     return
     end


	FUNCTION xpaac(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE AC CHANNEL OF THE WIND X PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(10)
C
C	COMPONENT DESIGNATIONS ARE SAME AS SCHEMATIC
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2,Y3,Z3,OPAMPIN,ZMEU
	DATA R9,C9,R10,CINP /5.E8,23.6E-12,5.E8,4.37E-12/
	DATA C29,R43,C12,R28/ 1.E-7,47.E+3,15.E-9,100.E+3/
	DATA R29,C13,R12,C26/ 470.,3.49E-9,10.E3,86.9E-9/
	DATA C15,R32,C27,R11/ 0.,10.E3,470.E-12,1.5E3/
	DATA C25,R39,C30/829.E-9,330.,29.9E-9/
	DATA CMEU,RMEU /20.E-9,300./
	DATA TWOPI /6.2831853/
C
C	TO BE CHANGED FOR Y,Z:  R11,R32,C27,R9,C9,R10
C
C
C	C30 = 30.9E-9                     ! ADJUSTING EX
C	C13 = 3.7E-9                     ! ADJUSTING EX
C
C	C30 = CVAR(1)
C	C26 = CVAR(2)
C	C25 = CVAR(3)
C	C13 = CVAR(4)
C
	C16 = 1.185E-9                            ! ADJUSTING EY
	C9  = 24.5E-12                            ! ADJUSTING EY
	CINP = 4.757E-12                          ! ADJUSTING EY
C
	C30 = 30.9E-9                     ! ADJUSTING EX
	C13 = 3.7E-9                     ! ADJUSTING EX
C
	C30 = CVAR(1)
	C26 = CVAR(2)
	C25 = CVAR(3)
	C13 = CVAR(4)
	C29 = CVAR(5)
	C12 = CVAR(6)
C
	CGAIN = 0.
	EXACPA=0.
	XPAAC=0.
	IF(F.EQ.0.) RETURN
	W = TWOPI*F
	CGAIN = 1.
C
C	DIVISION OF SIGNAL BEFORE FOLLOWER
C
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C
C	EFFECT OF OUTPUT OP AMP
C
C	FILTERING BEFORE INPUT
	Z1 = R28                 	! LAST LOAD BEFORE OP AMP
	WC12 = W*C12
	Z2 = CMPLX(R28,-1./WC12)        !  LAST RC
	Y1 = 1./CMPLX(R43,0.) + 1./Z2   !  LAST RC IN PARALLEL WITH R43
	WC29 = W*C29
	Z3 = 1./Y1 + CMPLX(0.,-1./WC29) !  LOAD ON FOLLOWER
	OPAMPIN = CGAIN*(Z1/Z2)*(1./Y1/Z3)
C
C	OP AMP GAIN
C
C	Z3 FROM NEG. INPUT TO GROUND
	WC13 = W*C13
	Z1 = CMPLX(R29,-1./WC13)
	WC26 = W*C26
	Z2 = CMPLX(R12,-1./WC26)
	Y1 = 1./Z1 + 1./Z2                  ! Y FROM NEG INPUT TO GROUND
	Z3 = 1./Y1                          ! Z FROM NEG INPUT TO GROUND
C	Z2 FROM OUTPUT TO NEG INPUT
	WC27 = W*C27
	Z1 = CMPLX(R11,-1./WC27)
	WC15 = W*C15
	Y1 = CMPLX(1./R32,WC15)
	Y2 = Y1 + 1./Z1
	Z2 = 1./Y2
	CGAIN = OPAMPIN*(Z3 + Z2)/Z3
C
C	FILTERING AFTER OP AMP OUTPUT
C
	WC30 = W*C30
	RMINN = 22.1E3                ! input resistance on 210 board
	Y1 = CMPLX(1./RMINN,WC30)
	Z1 = R39 + 1./Y1
	WC25 = W*C25
C	RTNR = .42e5		      ! total TNR load
	ZMEU = 47. + CMPLX(RMEU,-1./W/CMEU)
	Y3 = 1./ZMEU + 1./Z1
	Z2 = CMPLX(0.,-1./WC25)
	CGAIN = CGAIN/(1.+Y3*Z2)/Y1/Z1
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	EXACPA = CABS(CGAIN)
	XPAAC = EXACPA
	RETURN
	END


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

! compute spline coefficients

  subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)

  implicit none

! tangent to the spline imposed at the first and last points
  double precision, intent(in) :: tangent_first_point,tangent_last_point

! number of input points and coordinates of the input points
  integer, intent(in) :: npoint
  double precision, dimension(npoint), intent(in) :: xpoint,ypoint

! spline coefficients output by the routine
  double precision, dimension(npoint), intent(out) :: spline_coefficients

  integer :: i

  double precision, dimension(:), allocatable :: temporary_array

  allocate(temporary_array(npoint))

  spline_coefficients(1) = - 1.d0 / 2.d0

  temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)

  do i = 2,npoint-1

    spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
       / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)

    temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
       - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
       - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
       / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)

  enddo

  spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
      * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
      - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)

  do i = npoint-1,1,-1
    spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
  enddo

  deallocate(temporary_array)

  end subroutine spline_construction

!
! ------------------------------------------------------------------------------------------------
!

! evaluate a spline

  subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)

  implicit none

! number of input points and coordinates of the input points
  integer, intent(in) :: npoint
  double precision, dimension(npoint), intent(in) :: xpoint,ypoint

! spline coefficients to use
  double precision, dimension(npoint), intent(in) :: spline_coefficients

! abscissa at which we need to evaluate the value of the spline
  double precision, intent(in):: x_evaluate_spline

! ordinate evaluated by the routine for the spline at this abscissa
  double precision, intent(out):: y_spline_obtained

  integer :: index_loop,index_lower,index_higher

  double precision :: coef1,coef2

! initialize to the whole interval
  index_lower = 1
  index_higher = npoint

! determine the right interval to use, by dichotomy
  do while (index_higher - index_lower > 1)
! compute the middle of the interval
    index_loop = (index_higher + index_lower) / 2
    if(xpoint(index_loop) > x_evaluate_spline) then
      index_higher = index_loop
    else
      index_lower = index_loop
    endif
  enddo

! test that the interval obtained does not have a size of zero
! (this could happen for instance in the case of duplicates in the input list of points)
  if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'

  coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
  coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))

  y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
        ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
         (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0

  end subroutine spline_evaluation

!
! ------------------------------------------------------------------------------------------------
!

!--- spline to describe the interfaces

double precision function value_spline(x,xinterface,zinterface,coefs_interface,npoints_interface)

  implicit none

  integer npoints_interface
  double precision x,xp
  double precision, dimension(npoints_interface) :: xinterface,zinterface,coefs_interface

  value_spline = 0.d0

  xp = x

  ! assign the value on the edge if point is outside the model
  if(xp < xinterface(1)) xp = xinterface(1)
  if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)

  call spline_evaluation(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)

end function value_spline


      REAL*8 FUNCTION EQVANG(ANGLE)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE TAKES AN ANGLE, POSSIBLY OUTSIDE THE -TWOPI TO +TWOPI
C  RANGE, AND CONVERTS IT TO THE EQUIVALENT ANGLE IN THE ZERO TO TWOPI
C  RANGE.
C
C  VARIABLE   DIM  TYPE  I/O  DESCRIPTION
C  --------   ---  ----  ---  -----------
C
C  ANGLE       1    R*8   I   THE ANGLE TO BE CONVERTED. RADIANS.
C
C  EQVANG      1    R*8   O   THE EQUIVALENT ANGLE IN THE RANGE EQUAL TO
C                             OR GREATER THAN ZERO AND LESS THAN TWOPI.
C                             RADIANS.
C
C***********************************************************************
C
C  BY C PETRUZZO. 7/83.
C
C***********************************************************************
C
      REAL*8 TWOPI/ 6.283185307179586D0 /
C
      TEMP = DMOD(DABS(ANGLE),TWOPI)
      IF(TEMP.NE.0.D0 .AND. ANGLE.LT.0.D0) TEMP=TWOPI-TEMP
C
      EQVANG = TEMP
C
      RETURN
      END


      SUBROUTINE qroot(p,n,b,c,eps)
      INTEGER n,NMAX,ITMAX
      REAL b,c,eps,p(n),TINY
      PARAMETER (NMAX=20,ITMAX=20,TINY=1.0e-6)
CU    USES poldiv
      INTEGER iter
      REAL delb,delc,div,r,rb,rc,s,sb,sc,d(3),q(NMAX),qq(NMAX),rem(NMAX)
      d(3)=1.
      do 11 iter=1,ITMAX
        d(2)=b
        d(1)=c
        call poldiv(p,n,d,3,q,rem)
        s=rem(1)
        r=rem(2)
        call poldiv(q,n-1,d,3,qq,rem)
        sc=-rem(1)
        rc=-rem(2)
        sb=-c*rc
        rb=sc-b*rc
        div=1./(sb*rc-sc*rb)
        delb=(r*sc-s*rc)*div
        delc=(-r*sb+s*rb)*div
        b=b+delb
        c=c+delc
        if((abs(delb).le.eps*
     *abs(b).or.abs(b).lt.TINY).and.(abs(delc).le.eps*
     *abs(c).or.abs(c).lt.TINY)) return
11    continue
      pause 'too many iterations in qroot'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/qroot.for


! Copyright (c) "2012, Alexandr Fonari
!                URL: https://github.com/alexandr-fonari/emc
!                License: MIT License"

program emc_gen ! version 1.0
use emc_functions
implicit none
real(kind=8), parameter :: b2a = 0.52917721092d0
real(kind=8), parameter :: pi = 4.d0*DATAN(1.d0)
integer(kind=4), parameter :: nkpoints = 61
integer(kind=4), parameter :: iunt = 10, ilog = 11, w = 1 ! k point weight for VASP
character(len=8), parameter :: version_number = '1.5f'

real(kind=8) :: kp(3), kpc(3), dk, E(-2:2,-2:2,-2:2), A(4), f(3,3), g(3,3)
integer(kind=4) :: i, i1, j, j1, band
character prg

open(unit=ilog,file='emc_gen.log',form='formatted')
write(ilog,*) "Effective Mass Calculator generator ", version_number
call print_time(ilog)
write(ilog,*)

open(unit=iunt,file='inp',form='formatted')
    read(iunt,fmt=*) (kp(i),i=1,size(kp))
    read(iunt,fmt=*) dk
    read(iunt,fmt=*) band
    read(iunt,fmt=*) prg
    read(iunt,*) ((f(i,j),j=1,3),i=1,3)
close(iunt)

write(ilog,"(A,I5,F10.6)") "band, dk: ", band, dk

if(prg .eq. 'V') then
    dk = dk/(2.0D0*pi*b2a)
    write(ilog,"(A,F10.6)") "dk will be converted to VASP units (2Pi/A): ", dk
end if
write(ilog,*)

! g = inverse(transpose(f)), will do it in two steps
g=f
g=transpose(g)
call inverse(g, 3)
g=g*2.d0*pi

write(ilog,*) "direct lattice vectors              reciprocal lattice vectors"
do i=1,3
    write(ilog,"(3F10.6,A,3F10.6)") , (f(i,j), j=1,3), "     ", (g(i,j), j=1,3)
end do
write(ilog,*)

kpc = pureDEGMV(g, kp, 'T')
write(ilog,*) "k-point in: reciprocal space       reciprocal Cartesian space"
write(ilog,"(3F10.6,A,3F10.6)") (kp(j), j=1,3), "     ", (kpc(j), j=1,3)

! write KPOINTS file ###########################################

open(unit=iunt,file='KPOINTS',form='formatted')

write(unit=iunt,fmt='(A,F7.4,F7.4,F7.4,A,F7.5)') 'kpc: ', (kpc(j), j=1,3), ', dk: ', dk
write(unit=iunt,fmt='(I2)') nkpoints
if(prg .eq. 'C') then
    write(unit=iunt,fmt='(A)') 'Reciprocal'
else
    write(unit=iunt,fmt='(A)') 'Cartesian'
end if

call set_next_eigeval(iunt, g, kpc, 0, 0, 0, w, dk, prg) ! 0 0 0

! http://stackoverflow.com/questions/9791001/loop-in-fortran-from-a-list
A = (/ -2, -1, 1, 2 /)
! x
do i = 1, size(A)
    i1 = A(i)
    call set_next_eigeval(iunt, g, kpc, i1, 0, 0, w, dk, prg)
end do

! y
do i = 1, size(A)
    i1 = A(i)
    call set_next_eigeval(iunt, g, kpc, 0, i1, 0, w, dk, prg)
end do

! z
do i = 1, size(A)
    i1 = A(i)
    call set_next_eigeval(iunt, g, kpc, 0, 0, i1, w, dk, prg)
end do

! xy
do i = 1, size(A)
    i1 = A(i)
    do j=1, size(A)
        j1 = A(j)
        call set_next_eigeval(iunt, g, kpc, j1, i1, 0, w, dk, prg)
    end do
end do

! xz
do i = 1, size(A)
    i1 = A(i)
    do j=1, size(A)
        j1 = A(j)
        call set_next_eigeval(iunt, g, kpc, j1, 0, i1, w, dk, prg)
    end do
end do

! yz
do i = 1, size(A)
    i1 = A(i)
    do j=1, size(A)
        j1 = A(j)
        call set_next_eigeval(iunt, g, kpc, 0, j1, i1, w, dk, prg)
    end do
end do

close(30)

end program

subroutine set_next_eigeval(iunt, g, kp, i, j, k, w, dk, prg)
    use emc_functions
    implicit none
    integer(kind=4), intent(in) :: iunt, i, j, k, w
    real(kind=8), intent(in) :: g(3,3), kp(3), dk
    character, intent(in) :: prg
    real(kind=8) :: kp1(3)

    kp1(1) = kp(1)+dble(i)*dk
    kp1(2) = kp(2)+dble(j)*dk
    kp1(3) = kp(3)+dble(k)*dk

    if(prg .eq. 'C') then
        kp1 = pureDGESV(g, kp1, 'T') ! get reciprocal coords
    end if

    write(unit=iunt,fmt='(F15.10,F15.10,F15.10,F5.1)') kp1(1), kp1(2), kp1(3), dble(w)
    ! write(unit=iunt,fmt='(I5,I5,I5)') i, j, k
    return
end subroutine


SUBROUTINE dple(rowk, n, b, c, ierr)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-16  Time: 12:26:32

!     ******************************************************************
!     SOLUTION OF LINEAR EQUATIONS WITH REDUCED STORAGE
!     ******************************************************************

! Uses the Henderson-Wassyng partial pivot algorithm.
! Wassyng, A. 'Solving Ax = b: A method with reduced storage requirements',
! SIAM J. Numerical Analysis, vol.19 (1982), pp. 197-204.

! The user must provide a routine ROWK to return the requested row of the
! matrix A.

! N.B. Arguments D and IP have been removed.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(IN)   :: b(n)
REAL (dp), INTENT(OUT)  :: c(n)
INTEGER, INTENT(OUT)    :: ierr

! EXTERNAL rowk
INTERFACE
  SUBROUTINE rowk(n, k, r)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)     :: n, k
    REAL (dp), INTENT(OUT)  :: r(:)
  END SUBROUTINE rowk
END INTERFACE

! Local variables

REAL (dp)  :: bk, cj, ck, c1, dkj
REAL (dp), PARAMETER  :: zero = 0.0_dp
REAL (dp)  :: wk(n*n/4 + n + 3)
INTEGER    :: i, iflag, ij, ijold, ik, iwk(n), j, k, kjold, km1, kp1,   &
              last, lastm1, lcol, lcolp1, m, maxwk, mjold, nm1, np1

!     SET THE NECESSARY CONSTANTS

ierr = 0
maxwk = n * n / 4 + n + 3
np1 = n + 1
k = 1
iflag = -1

!     GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM

CALL rowk(n, 1, c)
bk = b(1)

IF (n <= 1) THEN
  IF (c(1) == zero) GO TO 130
  c(1) = bk / c(1)
  RETURN
END IF

!     FIND THE PIVOT FOR COLUMN 1

m = 1
DO  i = 2, n
  IF (ABS(c(m)) < ABS(c(i))) m = i
END DO

iwk(1) = m
c1 = c(m)
c(m) = c(1)
c(1) = c1
IF (c(1) /= zero) THEN

!     FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D

  DO  i = 2, n
    wk(i-1) = -c(i) / c(1)
  END DO
  wk(n) = bk / c(1)

!     K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM

  DO  k = 2, n
    kp1 = k + 1
    km1 = k - 1

!       GET COLUMN K

    CALL rowk(n, k, c)
    DO  j = 1, km1
      m = iwk(j)
      cj = c(j)
      c(j) = c(m)
      c(m) = cj
    END DO
    bk = b(k)

    iflag = -iflag
    lcol = np1 - k
    lcolp1 = lcol + 1
    lastm1 = 1
    last = maxwk - n + k
    IF (k /= 2) THEN

      lastm1 = maxwk - n + km1
      IF (iflag < 0) last = last - n + k - 2
      IF (iflag > 0) lastm1 = lastm1 - n + k - 3
    END IF

!     J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE

    DO  j = 1, km1
      cj = c(j)
      ij = (j-1) * lcolp1
      IF (j == km1) ij = lastm1 - 1

!     I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1

      DO  i = k, n
        ij = ij + 1
        c(i) = c(i) + wk(ij) * cj
      END DO
      bk = bk - wk(ij+1) * cj
    END DO

!       K=N CASE

    m = k
    IF (k >= n) THEN
      IF (c(k) == zero) GO TO 130
      wk(last) = bk / c(k)
    ELSE

!     FIND THE PIVOT

      DO  i = kp1, n
        IF (ABS(c(m)) < ABS(c(i))) m = i
      END DO

      iwk(k) = m
      ck = c(m)
      c(m) = c(k)
      c(k) = ck
      IF (c(k) == zero) GO TO 130

!     FIND THE K-TH ELEMENTARY MATRIX

      ik = last
      DO  i = kp1, n
        wk(ik) = -c(i) / c(k)
        ik = ik + 1
      END DO
      wk(ik) = bk / c(k)
    END IF

!     FORM THE PRODUCT OF THE ELEMENTARY MATRICES

    DO  j = 1, km1
      kjold = j * lcolp1 + k - np1
      mjold = kjold + m - k
      ij = (j-1) * lcol
      ijold = ij + j
      IF (j == km1) THEN

        kjold = lastm1
        mjold = lastm1 + m - k
        ijold = lastm1
      END IF

      ik = last - 1
      dkj = wk(mjold)
      wk(mjold) = wk(kjold)
      DO  i = kp1, np1
        ij = ij + 1
        ijold = ijold + 1
        ik = ik + 1
        wk(ij) = wk(ijold) + wk(ik) * dkj
      END DO
    END DO
  END DO

  last = maxwk
  IF (iflag < 0) last = maxwk - 2
  wk(n) = wk(last)

!     INSERT THE SOLUTION IN C

  c(1:n) = wk(1:n)

  nm1 = n - 1
  DO  i = 1, nm1
    k = n - i
    m = iwk(k)
    ck = c(k)
    c(k) = c(m)
    c(m) = ck
  END DO
  RETURN
END IF

!     THE SYSTEM IS SINGULAR

130 ierr = k
RETURN
END SUBROUTINE dple

SUBROUTINE rowk(n, k, r)

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
INTEGER, INTENT(IN)     :: n, k
REAL (dp), INTENT(OUT)  :: r(:)

INTEGER    :: i
REAL (dp)  :: temp

r(k) = 1.0_dp
IF (k > 1) THEN
  temp = 1.0_dp
  DO i = 1, k-1
    temp = 0.99_dp * temp
    r(k-i) = temp
  END DO
END IF

IF (k < n) THEN
  temp = 1.0_dp
  DO i = 1, n-k
    temp = 0.99_dp * temp
    r(k+i) = temp
  END DO
END IF

RETURN
END SUBROUTINE rowk

PROGRAM Test_DPLE
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)

REAL (dp)  :: a(100), x(100), b(100), error, temp, soln(100)
INTEGER    :: i, ierr, row

INTERFACE
  SUBROUTINE dple(rowk, n, b, c, ierr)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)     :: n
    REAL (dp), INTENT(IN)   :: b(n)
    REAL (dp), INTENT(OUT)  :: c(n)
    INTEGER, INTENT(OUT)    :: ierr
    INTERFACE
      SUBROUTINE rowk(n, k, r)
        IMPLICIT NONE
        INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
        INTEGER, INTENT(IN)     :: n, k
        REAL (dp), INTENT(OUT)  :: r(:)
      END SUBROUTINE rowk
    END INTERFACE
  END SUBROUTINE dple

  SUBROUTINE rowk(n, k, r)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)     :: n, k
    REAL (dp), INTENT(OUT)  :: r(:)
  END SUBROUTINE rowk
END INTERFACE

! Generate the solution using the random number generator
CALL RANDOM_NUMBER(x)
! Calculate the right-hand side
DO row = 1, 100
  CALL rowk(100, row, a)
  b(row) = DOT_PRODUCT(a, x)
END DO

CALL dple(rowk, 100, b, soln, ierr)
IF (ierr == 0) THEN
  temp = 0.0
  DO i = 1, 100
    error = ABS(soln(i) - x(i))
    temp = MAX(temp, error)
  END DO
  WRITE(*, '(a, g13.5)') ' Max. error = ', temp
ELSE
  WRITE(*, *) ' Error = ', ierr
END IF

STOP
END PROGRAM Test_DPLE


module fccoMod
 implicit none
 private
 public :: fccoInit,fcco,q1c,q1co

 real, parameter :: n0=1520, &    	! cm^-3
                    xifuv=3.      	! FUV absorption constant (2-4)

 real, save :: metal
 integer, save :: poly

 contains

subroutine fccoInit
 use ElementsMod
 use MoleculeMod

 call InitElements()
 metal=zQ()/solarzQ()
 poly=polyQ()
 if(poly.NE.0.AND.poly.NE.1) call fccoError('poly error',poly)

end subroutine

function fcco(n,G0,Pe,Z)
 real :: fcco,n,G0,Pe,zz
 real, optional :: Z

 zz=metal
 if(present(Z)) zz=Z
 if(poly.EQ.0) then
  fcco=fccoco(n,G0,zz,Pe)
 else
  fcco=fccolog(n,G0,zz,Pe)
 endif
end function

function q1c(t)
 real :: q1c,t
 real, parameter :: e1=23.6,e2=62.4 ! K
 integer, parameter :: g0=1,g1=3,g2=5
 q1c=g1*exp(-e1/t)/(g0+g1*exp(-e1/t)+g2*exp(-e2/t))
end function

function q1co(t)
 real :: q1co,t
 real, parameter :: e1=5.5 ! K
 integer, parameter :: g1=3
 q1co=g1*exp(-e1/t)/(2*t/e1)
end function

function e2solvelog(a1,a2) result(xnew)
 real :: a1,a2,x,xnew,en(0:2)
 integer :: i,nmax=100
 xnew=1.0001
 call ENXB(2,alog(xnew)*a1,en)
 if(en(2)-a2*xnew.LT.0) return
 i=0
10 i=i+1
  x=xnew
  call ENXB(2,alog(x)*a1,en)
  xnew=x+(en(2)-a2*x)/(en(1)*a1/x+a2)
  if(xnew.LT.1) then
   xnew=1.
   return
  endif
  if(abs(xnew-x).GT.1.e-5.AND.i.LT.nmax) goto 10
  call enxb(2,alog(xnew)*a1,en)
  if(abs(en(2)-a2*xnew).GT.1.e-3) then
   call fccoError('e2solvelog error',i)
  stop
 endif

end function

function e2solve(x)
 real :: x,thnew,th,e2solve
 integer :: i,nmax=100

thnew=1.d-9
if(x.gt.exp(-thnew)-thnew*E1(thnew)) then
 e2solve=thnew
 return
endif
if(x.LE.1.d-40) then
 e2solve=87.6081992538658
 return
endif
i=0
10 i=i+1
 th=thnew
 thnew=th+(exp(-th)-th*E1(th)-x)/E1(th)
 if(abs(thnew-th).GT.1.e-5.AND.i.LE.nmax) goto 10
 if((exp(-th)-th*E1(th)-x).GT.1.e-5) then
  call fccoError(' e2solve error',i)
  stop
 endif
 e2solve=thnew
end function

function fccolog(n,G0,Z,Pe) result(fcoc)
 real :: n,G0,Z,Pe,a1,a2,x,fcoc

 a1=1.11*Z*n0/1.d3*sqrt(pe/1.d4)*xifuv
 a2=(1+24.8*Z)*8./9.*n/1.d6/G0
 x=e2solvelog(a1,a2)
 fcoc=1/x**2
end function

function fccoco(n,G0,Z,Pe)
 real :: n,G0,Z,Pe,xia,fccoco

 xia=e2solve(REAL(4./3.*n/1.d6/G0*(1+24.8*Z)))
 fccoco=MAX(0.d0,1-xiA*1.d3/n0/xifuv/1.66/Z/sqrt(Pe/1.d4))**3
end function

        SUBROUTINE ENXB(N,X,EN)
!
!       ===============================================
!       Purpose: Compute exponential integral En(x)
!       Input :  x --- Argument of En(x)
!                n --- Order of En(x)  (n = 0,1,2,...)
!       Output:  EN(n) --- En(x)
!       ===============================================
!
        REAL X,EN,R,S,RP,PS,ENS,T,T0,S0
        INTEGER N,J,K,L,M
        DIMENSION EN(0:N)
        IF (X.EQ.0.0) THEN
           EN(0)=1.0D+300
           EN(1)=1.0D+300
           DO K=2,N
              EN(K)=1.0D0/(K-1.0)
           ENDDO
           RETURN
        ELSE IF (X.LE.1.0) THEN
           EN(0)=EXP(-X)/X
           DO L=1,N
              RP=1.0D0
              DO J=1,L-1
                 RP=-RP*X/J
              ENDDO
              PS=-0.5772156649015328D0
              DO M=1,L-1
                 PS=PS+1.0D0/M
              ENDDO
              ENS=RP*(-LOG(X)+PS)
              S=0.0D0
              DO M=0,20
                 IF (M.EQ.L-1) CYCLE
                 R=1.0D0
                 DO J=1,M
                    R=-R*X/J
                 ENDDO
                 S=S+R/(M-L+1.0D0)
                 IF (ABS(S-S0).LT.ABS(S)*1.0D-15) EXIT
                 S0=S
              ENDDO
              EN(L)=ENS-S
           ENDDO
        ELSE
           EN(0)=EXP(-X)/X
           M=15+INT(100.0/X)
           DO L=1,N
              T0=0.0D0
              DO K=M,1,-1
                 T0=(L+K-1.0D0)/(1.0D0+K/(X+T0))
              ENDDO
              T=1.0D0/(X+T0)
              EN(L)=EXP(-X)*T
           ENDDO
        ENDIF
        END SUBROUTINE

        FUNCTION E1(X)
!
!       ============================================
!       Purpose: Compute exponential integral E1(x)
!       Input :  x  --- Argument of E1(x)
!       Output:  E1 --- E1(x) ( x > 0 )
!       ============================================
!
        REAL X,E1,ES1,ES2
        IF (X.EQ.0.0) THEN
           E1=1.0D+300
        ELSE IF (X.LE.1.0) THEN
           E1=-LOG(X)+((((1.07857D-3*X-9.76004D-3)*X+5.519968D-2)*X &
     &        -0.24991055D0)*X+0.99999193D0)*X-0.57721566D0
        ELSE
           ES1=(((X+8.5733287401D0)*X+18.059016973D0)*X &
     &         +8.6347608925D0)*X+0.2677737343D0
           ES2=(((X+9.5733223454D0)*X+25.6329561486D0)*X &
     &         +21.0996530827D0)*X+3.9584969228D0
           E1=EXP(-X)/X*ES1/ES2
        ENDIF
        RETURN
        END FUNCTION

 subroutine fccoError(string,i)
  character(*) :: string
  integer, optional :: i

  print*,' fccoError detected:'

  if(present(i)) then
   print*,string,i
  else
   print*,string
  endif

  stop
 end subroutine

end module

subroutine fccotest
 use fccoMod
 real :: x,y,n,G0,Z,Pe

 call fccoInit

 10 read*,n,G0,Z,Pe
 if(n.LT.0) stop
 y=fcco(n,G0,Pe,Z)
 print*,n,G0,Z,Pe,y
 goto 10
end

subroutine enxbtest
 use fccoMod
  integer :: y, n=5
  real :: x, en(5)

    do i=0,100
      call enxb(n,i*0.1, en)
      print*, i, en
    enddo

end


MODULE SVD
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

! Based upon routines from the NSWC (Naval Surface Warfare Center),
! which were based upon LAPACK routines.

! Code converted using TO_F90 by Alan Miller
! Date: 2003-11-11  Time: 17:50:44

CONTAINS

SUBROUTINE drotg(da, db, dc, ds)

!     DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08

!     CONSTRUCT THE GIVENS TRANSFORMATION

!         ( DC  DS )
!     G = (        ) ,    DC**2 + DS**2 = 1 ,
!         (-DS  DC )

!     WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR  (DA,DB)**T .

!     THE QUANTITY R = (+/-)SQRT(DA**2 + DB**2) OVERWRITES DA IN
!     STORAGE.  THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH
!     ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM:
!           IF Z=1  SET  DC=0.D0  AND  DS=1.D0
!           IF DABS(Z) < 1  SET  DC=SQRT(1-Z**2)  AND  DS=Z
!           IF DABS(Z) > 1  SET  DC=1/Z  AND  DS=SQRT(1-DC**2)

!     NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL
!     NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX.

! ------------------------------------------------------------------

REAL (dp), INTENT(IN OUT)  :: da
REAL (dp), INTENT(IN OUT)  :: db
REAL (dp), INTENT(OUT)     :: dc
REAL (dp), INTENT(OUT)     :: ds

REAL (dp)  :: u, v, r
IF (ABS(da) <= ABS(db)) GO TO 10

! *** HERE ABS(DA) > ABS(DB) ***

u = da + da
v = db / u

!     NOTE THAT U AND R HAVE THE SIGN OF DA

r = SQRT(.25D0 + v**2) * u

!     NOTE THAT DC IS POSITIVE

dc = da / r
ds = v * (dc + dc)
db = ds
da = r
RETURN

! *** HERE ABS(DA) <= ABS(DB) ***

10 IF (db == 0.d0) GO TO 20
u = db + db
v = da / u

!     NOTE THAT U AND R HAVE THE SIGN OF DB
!     (R IS IMMEDIATELY STORED IN DA)

da = SQRT(.25D0 + v**2) * u

!     NOTE THAT DS IS POSITIVE

ds = db / da
dc = v * (ds + ds)
IF (dc == 0.d0) GO TO 15
db = 1.d0 / dc
RETURN
15 db = 1.d0
RETURN

! *** HERE DA = DB = 0.D0 ***

20 dc = 1.d0
ds = 0.d0
RETURN

END SUBROUTINE drotg

SUBROUTINE dswap1 (n, dx, dy)

!     INTERCHANGES TWO VECTORS.
!     USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
!     JACK DONGARRA, LINPACK, 3/11/78.
!     This version is for increments = 1.

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: dx(*)
REAL (dp), INTENT(IN OUT)  :: dy(*)

REAL (dp)  :: dtemp
INTEGER    :: i, m, mp1

IF(n <= 0) RETURN

!       CODE FOR BOTH INCREMENTS EQUAL TO 1

!       CLEAN-UP LOOP

m = MOD(n,3)
IF( m == 0 ) GO TO 40
DO  i = 1,m
  dtemp = dx(i)
  dx(i) = dy(i)
  dy(i) = dtemp
END DO
IF( n < 3 ) RETURN
40 mp1 = m + 1
DO  i = mp1,n,3
  dtemp = dx(i)
  dx(i) = dy(i)
  dy(i) = dtemp
  dtemp = dx(i + 1)
  dx(i + 1) = dy(i + 1)
  dy(i + 1) = dtemp
  dtemp = dx(i + 2)
  dx(i + 2) = dy(i + 2)
  dy(i + 2) = dtemp
END DO
RETURN
END SUBROUTINE  dswap1

SUBROUTINE  drot1 (n, dx, dy, c, s)

!     APPLIES A PLANE ROTATION.
!     JACK DONGARRA, LINPACK, 3/11/78.
!     This version is for increments = 1.

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: dx(*)
REAL (dp), INTENT(IN OUT)  :: dy(*)
REAL (dp), INTENT(IN)      :: c
REAL (dp), INTENT(IN)      :: s

REAL (dp)  :: dtemp
INTEGER    :: i

IF(n <= 0) RETURN
!       CODE FOR BOTH INCREMENTS EQUAL TO 1

DO  i = 1,n
  dtemp = c*dx(i) + s*dy(i)
  dy(i) = c*dy(i) - s*dx(i)
  dx(i) = dtemp
END DO
RETURN
END SUBROUTINE  drot1

SUBROUTINE dsvdc(x, n, p, s, e, u, v, job, info)

INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: p
REAL (dp), INTENT(IN OUT)  :: x(:,:)
REAL (dp), INTENT(OUT)     :: s(:)
REAL (dp), INTENT(OUT)     :: e(:)
REAL (dp), INTENT(OUT)     :: u(:,:)
REAL (dp), INTENT(OUT)     :: v(:,:)
INTEGER, INTENT(IN)        :: job
INTEGER, INTENT(OUT)       :: info

!     DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X
!     BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
!     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
!     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
!     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.

!     ON ENTRY

!         X         DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N.
!                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
!                   DECOMPOSITION IS TO BE COMPUTED.  X IS
!                   DESTROYED BY DSVDC.

!         LDX       INTEGER.
!                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.

!         N         INTEGER.
!                   N IS THE NUMBER OF ROWS OF THE MATRIX X.

!         P         INTEGER.
!                   P IS THE NUMBER OF COLUMNS OF THE MATRIX X.

!         LDU       INTEGER.
!                   LDU IS THE LEADING DIMENSION OF THE ARRAY U.
!                   (SEE BELOW).

!         LDV       INTEGER.
!                   LDV IS THE LEADING DIMENSION OF THE ARRAY V.
!                   (SEE BELOW).

!         JOB       INTEGER.
!                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
!                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
!                   WITH THE FOLLOWING MEANING

!                        A.EQ.0    DO NOT COMPUTE THE LEFT SINGULAR VECTORS.
!                        A.EQ.1    RETURN THE N LEFT SINGULAR VECTORS IN U.
!                        A.GE.2    RETURN THE FIRST MIN(N,P) SINGULAR
!                                  VECTORS IN U.
!                        B.EQ.0    DO NOT COMPUTE THE RIGHT SINGULAR VECTORS.
!                        B.EQ.1    RETURN THE RIGHT SINGULAR VECTORS IN V.

!     ON RETURN

!         S         DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P).
!                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE SINGULAR
!                   VALUES OF X ARRANGED IN DESCENDING ORDER OF MAGNITUDE.

!         E         DOUBLE PRECISION(P).
!                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
!                   DISCUSSION OF INFO FOR EXCEPTIONS.

!         U         DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N.  IF
!                                   JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2
!                                   THEN K.EQ.MIN(N,P).
!                   U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS.
!                   U IS NOT REFERENCED IF JOBA.EQ.0.  IF N.LE.P
!                   OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X
!                   IN THE SUBROUTINE CALL.

!         V         DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P.
!                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
!                   V IS NOT REFERENCED IF JOB.EQ.0.  IF P.LE.N,
!                   THEN V MAY BE IDENTIFIED WITH X IN THE
!                   SUBROUTINE CALL.

!         INFO      INTEGER.
!                   THE SINGULAR VALUES (AND THEIR CORRESPONDING SINGULAR
!                   VECTORS) S(INFO+1),S(INFO+2),...,S(M) ARE CORRECT
!                   (HERE M=MIN(N,P)).  THUS IF INFO.EQ.0, ALL THE
!                   SINGULAR VALUES AND THEIR VECTORS ARE CORRECT.
!                   IN ANY EVENT, THE MATRIX B = TRANS(U)*X*V IS THE
!                   BIDIAGONAL MATRIX WITH THE ELEMENTS OF S ON ITS DIAGONAL
!                   AND THE ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U)
!                   IS THE TRANSPOSE OF U).  THUS THE SINGULAR VALUES
!                   OF X AND B ARE THE SAME.

!     LINPACK. THIS VERSION DATED 03/19/79 .
!     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.

!     DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.

!     EXTERNAL DROT
!     BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG
!     FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT

!     INTERNAL VARIABLES

INTEGER :: iter, j, jobu, k, kase, kk, l, ll, lls, lm1, lp1, ls, lu, m, maxit,  &
    mm, mm1, mp1, nct, nctp1, ncu, nrt, nrtp1
REAL (dp) :: t, work(n)
REAL (dp) :: b, c, cs, el, emm1, f, g, scale, shift, sl, sm, sn,  &
    smm1, t1, test, ztest
LOGICAL :: wantu, wantv

!     SET THE MAXIMUM NUMBER OF ITERATIONS.

maxit = 30

!     DETERMINE WHAT IS TO BE COMPUTED.

wantu = .false.
wantv = .false.
jobu = MOD(job,100)/10
ncu = n
IF (jobu > 1) ncu = MIN(n,p)
IF (jobu /= 0) wantu = .true.
IF (MOD(job,10) /= 0) wantv = .true.

!     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
!     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.

info = 0
nct = MIN(n-1, p)
s(1:nct+1) = 0.0_dp
nrt = MAX(0, MIN(p-2,n))
lu = MAX(nct,nrt)
IF (lu < 1) GO TO 170
DO  l = 1, lu
  lp1 = l + 1
  IF (l > nct) GO TO 20

!           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
!           PLACE THE L-TH DIAGONAL IN S(L).

  s(l) = SQRT( SUM( x(l:n,l)**2 ) )
  IF (s(l) == 0.0D0) GO TO 10
  IF (x(l,l) /= 0.0D0) s(l) = SIGN(s(l), x(l,l))
  x(l:n,l) = x(l:n,l) / s(l)
  x(l,l) = 1.0D0 + x(l,l)

  10 s(l) = -s(l)

  20 IF (p < lp1) GO TO 50
  DO  j = lp1, p
    IF (l > nct) GO TO 30
    IF (s(l) == 0.0D0) GO TO 30

!              APPLY THE TRANSFORMATION.

    t = -DOT_PRODUCT(x(l:n,l), x(l:n,j)) / x(l,l)
    x(l:n,j) = x(l:n,j) + t * x(l:n,l)

!           PLACE THE L-TH ROW OF X INTO  E FOR THE
!           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.

    30 e(j) = x(l,j)
  END DO

  50 IF (.NOT.wantu .OR. l > nct) GO TO 70

!           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK MULTIPLICATION.

  u(l:n,l) = x(l:n,l)

  70 IF (l > nrt) CYCLE

!           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
!           L-TH SUPER-DIAGONAL IN E(L).

  e(l) = SQRT( SUM( e(lp1:p)**2 ) )
  IF (e(l) == 0.0D0) GO TO 80
  IF (e(lp1) /= 0.0D0) e(l) = SIGN(e(l), e(lp1))
  e(lp1:lp1+p-l-1) = e(lp1:p) / e(l)
  e(lp1) = 1.0D0 + e(lp1)

  80 e(l) = -e(l)
  IF (lp1 > n .OR. e(l) == 0.0D0) GO TO 120

!              APPLY THE TRANSFORMATION.

  work(lp1:n) = 0.0D0
  DO  j = lp1, p
    work(lp1:lp1+n-l-1) = work(lp1:lp1+n-l-1) + e(j) * x(lp1:lp1+n-l-1,j)
  END DO
  DO  j = lp1, p
    x(lp1:lp1+n-l-1,j) = x(lp1:lp1+n-l-1,j) - (e(j)/e(lp1)) * work(lp1:lp1+n-l-1)
  END DO

  120 IF (.NOT.wantv) CYCLE

!              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
!              BACK MULTIPLICATION.

  v(lp1:p,l) = e(lp1:p)
END DO

!     SET UP THE FINAL BIDIAGONAL MATRIX OF ORDER M.

170 m = MIN(p,n+1)
nctp1 = nct + 1
nrtp1 = nrt + 1
IF (nct < p) s(nctp1) = x(nctp1,nctp1)
IF (n < m) s(m) = 0.0D0
IF (nrtp1 < m) e(nrtp1) = x(nrtp1,m)
e(m) = 0.0D0

!     IF REQUIRED, GENERATE U.

IF (.NOT.wantu) GO TO 300
IF (ncu < nctp1) GO TO 200
DO  j = nctp1, ncu
  u(1:n,j) = 0.0_dp
  u(j,j) = 1.0_dp
END DO

200 DO  ll = 1, nct
  l = nct - ll + 1
  IF (s(l) == 0.0D0) GO TO 250
  lp1 = l + 1
  IF (ncu < lp1) GO TO 220
  DO  j = lp1, ncu
    t = -DOT_PRODUCT(u(l:n,l), u(l:n,j)) / u(l,l)
    u(l:n,j) = u(l:n,j) + t * u(l:n,l)
  END DO

  220 u(l:n,l) = -u(l:n,l)
  u(l,l) = 1.0D0 + u(l,l)
  lm1 = l - 1
  IF (lm1 < 1) CYCLE
  u(1:lm1,l) = 0.0_dp
  CYCLE

  250 u(1:n,l) = 0.0_dp
  u(l,l) = 1.0_dp
END DO

!     IF IT IS REQUIRED, GENERATE V.

300 IF (.NOT.wantv) GO TO 350
DO  ll = 1, p
  l = p - ll + 1
  lp1 = l + 1
  IF (l > nrt) GO TO 320
  IF (e(l) == 0.0D0) GO TO 320
  DO  j = lp1, p
    t = -DOT_PRODUCT(v(lp1:lp1+p-l-1,l), v(lp1:lp1+p-l-1,j)) / v(lp1,l)
    v(lp1:lp1+p-l-1,j) = v(lp1:lp1+p-l-1,j) + t * v(lp1:lp1+p-l-1,l)
  END DO

  320 v(1:p,l) = 0.0D0
  v(l,l) = 1.0D0
END DO

!     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.

350 mm = m
iter = 0

!        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.

!     ...EXIT
360 IF (m == 0) GO TO 620

!        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET FLAG AND RETURN.

IF (iter < maxit) GO TO 370
info = m
!     ......EXIT
GO TO 620

!        THIS SECTION OF THE PROGRAM INSPECTS FOR NEGLIGIBLE ELEMENTS
!        IN THE S AND E ARRAYS.  ON COMPLETION
!        THE VARIABLES KASE AND L ARE SET AS FOLLOWS.

!           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L < M
!           KASE = 2     IF S(L) IS NEGLIGIBLE AND L < M
!           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L < M, AND
!                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
!           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).

370 DO  ll = 1, m
  l = m - ll
!        ...EXIT
  IF (l == 0) EXIT
  test = ABS(s(l)) + ABS(s(l+1))
  ztest = test + ABS(e(l))
  IF (ztest /= test) CYCLE
  e(l) = 0.0D0
!        ......EXIT
  EXIT
END DO

IF (l /= m - 1) GO TO 410
kase = 4
GO TO 480

410 lp1 = l + 1
mp1 = m + 1
DO  lls = lp1, mp1
  ls = m - lls + lp1
!           ...EXIT
  IF (ls == l) EXIT
  test = 0.0D0
  IF (ls /= m) test = test + ABS(e(ls))
  IF (ls /= l + 1) test = test + ABS(e(ls-1))
  ztest = test + ABS(s(ls))
  IF (ztest /= test) CYCLE
  s(ls) = 0.0D0
!           ......EXIT
  EXIT
END DO

IF (ls /= l) GO TO 450
kase = 3
GO TO 480

450 IF (ls /= m) GO TO 460
kase = 1
GO TO 480

460 kase = 2
l = ls
480 l = l + 1

!        PERFORM THE TASK INDICATED BY KASE.

SELECT CASE ( kase )
  CASE (    1)
    GO TO 490
  CASE (    2)
    GO TO 520
  CASE (    3)
    GO TO 540
  CASE (    4)
    GO TO 570
END SELECT

!        DEFLATE NEGLIGIBLE S(M).

490 mm1 = m - 1
f = e(m-1)
e(m-1) = 0.0D0
DO  kk = l, mm1
  k = mm1 - kk + l
  t1 = s(k)
  CALL drotg(t1, f, cs, sn)
  s(k) = t1
  IF (k == l) GO TO 500
  f = -sn*e(k-1)
  e(k-1) = cs*e(k-1)

  500 IF (wantv) CALL drot1(p, v(1:,k), v(1:,m), cs, sn)
END DO
GO TO 610

!        SPLIT AT NEGLIGIBLE S(L).

520 f = e(l-1)
e(l-1) = 0.0D0
DO  k = l, m
  t1 = s(k)
  CALL drotg(t1, f, cs, sn)
  s(k) = t1
  f = -sn*e(k)
  e(k) = cs*e(k)
  IF (wantu) CALL drot1(n, u(1:,k), u(1:,l-1), cs, sn)
END DO
GO TO 610

!        PERFORM ONE QR STEP.

!           CALCULATE THE SHIFT.

540 scale = MAX(ABS(s(m)), ABS(s(m-1)), ABS(e(m-1)), ABS(s(l)), ABS(e(l)))
sm = s(m)/scale
smm1 = s(m-1)/scale
emm1 = e(m-1)/scale
sl = s(l)/scale
el = e(l)/scale
b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0D0
c = (sm*emm1)**2
shift = 0.0D0
IF (b == 0.0D0 .AND. c == 0.0D0) GO TO 550
shift = SQRT(b**2+c)
IF (b < 0.0D0) shift = -shift
shift = c/(b + shift)

550 f = (sl + sm)*(sl - sm) - shift
g = sl*el

!           CHASE ZEROS.

mm1 = m - 1
DO  k = l, mm1
  CALL drotg(f, g, cs, sn)
  IF (k /= l) e(k-1) = f
  f = cs*s(k) + sn*e(k)
  e(k) = cs*e(k) - sn*s(k)
  g = sn*s(k+1)
  s(k+1) = cs*s(k+1)
  IF (wantv) CALL drot1(p, v(1:,k), v(1:,k+1), cs, sn)
  CALL drotg(f, g, cs, sn)
  s(k) = f
  f = cs*e(k) + sn*s(k+1)
  s(k+1) = -sn*e(k) + cs*s(k+1)
  g = sn*e(k+1)
  e(k+1) = cs*e(k+1)
  IF (wantu .AND. k < n) CALL drot1(n, u(1:,k), u(1:,k+1), cs, sn)
END DO
e(m-1) = f
iter = iter + 1
GO TO 610

!        CONVERGENCE.

!           MAKE THE SINGULAR VALUE  POSITIVE.

570 IF (s(l) >= 0.0D0) GO TO 590
s(l) = -s(l)
IF (wantv) v(1:p,l) = -v(1:p,l)

!           ORDER THE SINGULAR VALUE.

590 IF (l == mm) GO TO 600
!           ...EXIT
IF (s(l) >= s(l+1)) GO TO 600
t = s(l)
s(l) = s(l+1)
s(l+1) = t
IF (wantv .AND. l < p) CALL dswap1(p, v(1:,l), v(1:,l+1))
IF (wantu .AND. l < n) CALL dswap1(n, u(1:,l), u(1:,l+1))
l = l + 1
GO TO 590

600 iter = 0
m = m - 1

610 GO TO 360

620 RETURN
END SUBROUTINE dsvdc

END MODULE SVD


! { dg-do run }
! PR 21075:  Reshape with rank 7 used to segfault.
program main
  integer :: a(256), b(2,2,2,2,2,2,2)
  do i=1,256
     a(i) = i
  end do
  b = reshape(a(1:256:2), shape(b))
  do i1=1,2
     do i2=1,2
        do i3=1,2
           do i4=1,2
              do i5=1,2
                 do i6=1,2
                    do i7=1,2
                       if (b(i1,i2,i3,i4,i5,i6,i7) /= &
                            2*((i1-1)+(i2-1)*2+(i3-1)*4+(i4-1)*8+&
                            (i5-1)*16+(i6-1)*32+(i7-1)*64)+1) &
                            call abort
              end do
            end do
          end do
        end do
      end do
    end do
  end do
end program main


program problem1
  implicit none
  integer :: i,sum

  sum = 0
  do i=0,(1000-1)
     if (mod(i,3) == 0 .or. mod(i,5) == 0) then
        sum = sum + i
     end if
  end do
  print *, sum

end program problem1


module m1

contains

subroutine  cube_mean(x, y, z, r)
	real, intent(in) :: x
	real, intent(in) :: y
	real, intent(in) :: z
	real, intent(out) :: r

	r=x+y+z
	r = r / (3)
	r = r * (3)

end subroutine

end module


program double_loop_1

    integer,parameter :: n=139

    real*8 A(n, n)

    !$xev loop_tag
    do i=1,n
        do j=1,n
            A(i,j)=A(i-1,j)+A(i,j-1)
        end do
    end do

end program double_loop_1