 SUBROUTINE corr18(st11,st22,st33,st12,st13,st23,efpst,gm,props,a,b, &
                   ierr,ep,flag,is,np,curve,h)
 !-------------------------------------------------------------------
 !
 !     transversal Anisotropy for 3-D Solid element (TLF)
 !
 !-------------------------------------------------------------------
 USE lispa0
 USE mat_dba, ONLY : inte_cr
 IMPLICIT NONE

 REAL (kind=8),INTENT(IN) :: props(:),  & !material properties
                             gm,        & !elasticity shear modulus
                             a(:),      & !yield function matrix
                             b(:)         !flow rule matrix
 REAL (kind=8),INTENT(IN OUT) :: st11,st22,st33,st12,st13,st23 !trial and corrected stresses
 REAL (kind=8),INTENT(IN OUT) :: efpst    !effective plastic strain
                                          !(IN) present   (OUT) increment
 REAL (kind=8), POINTER :: curve(:,:)     !(3,np) yield stress
 REAL (kind=8),INTENT(OUT) :: ep(:)       !increment in plastic strains
 INTEGER (kind=4), INTENT(IN) :: is       !isotropic hardening model
 INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)
 INTEGER (kind=4), INTENT(IN) :: np       !number of points in CURVE
 LOGICAL, INTENT(OUT) :: flag             !.TRUE. if plastic  .FALSE. if elastic
 REAL (kind=8),INTENT(OUT), OPTIONAL :: h !plastic modulus
 !local variables
  REAL (kind=8), PARAMETER :: toler=1d-4, toler1=1d-6
  INTEGER (kind=4), PARAMETER :: miter=5

  REAL (kind=8) ::  s11,s22,s33,s12,s13,s23,epbar,fi,f0,     &
                    a1,a2,a3,a4,a5,a6,ap,dl,aux,yield,aprim, &
                    b1,b2,b3,b4,b5,b6,fp,de
  INTEGER (kind=4) k
!  INTEGER (kind=4), SAVE :: kk(miter) = 0  !it is a debug variable

 !------------ begin

 !     setup initial yield FUNCTION radius

 IF( is == 5 ) THEN        !for points defined yield value
   k = 1   !begin at first interval
   yield = inte_cr (curve,np,efpst,k) !c0
   aprim = curve(3,k)                 !c1
                                      !c0 = c0 - c1*efpst  !ordinate at 0
 ELSE
   !c0 = props(1)     !c0 constant or Initial yield
   !c1 = props(2)     !linear hardening or efref
   !c2 = props(3)     !exponent for non-linear hardening
   !c3 = props(4)     !residual flow stress
   CALL isoha14(is,yield,aprim,efpst,props(1),props(2),props(3),props(4))
 END IF

  !     calculate initial effective stress
  a1 =  a(1)*st11 + a(2)*st22 + a(3)*st33
  a2 =  a(2)*st11 + a(4)*st22 + a(5)*st33
  a3 =  a(3)*st11 + a(5)*st22 + a(6)*st33
  a4 =  a(7)*st12
  a5 =  a(8)*st13
  a6 =  a(9)*st23
  fi = SQRT( a1*st11 + a2*st22 + a3*st33 + a4*st12 + a5*st13 + a6*st23 )
  !     check initial yield FUNCTION

  f0 = fi-yield
  IF( f0/yield < toler) THEN

     !   IF the point is elastic

    flag = .FALSE.

  ELSE
    !   start iteration for satisfying consistency condition
    s11 = st11
    s22 = st22
    s33 = st33
    s12 = st12
    s13 = st13
    s23 = st23
    epbar = efpst
    DO k = 1,miter
      ! compute a vector
      a1 = a1/fi
      a2 = a2/fi
      a3 = a3/fi
      a4 = a4/fi
      a5 = a5/fi
      a6 = a6/fi
      ! compute flow rule
      b1 =  b(1)*s11+ b(2)*s22 + b(3)*s33
      b2 =  b(2)*s11+ b(4)*s22 + b(5)*s33
      b3 =  b(3)*s11+ b(5)*s22 + b(6)*s33
      b4 =  b(7)*s12
      b5 =  b(8)*s13
      b6 =  b(9)*s23
      fp = SQRT( b1*s11 + b2*s22 + b3*s33 + b4*s12 + b5*s13 + b6*s23 )
      b1 = b1/fp
      b2 = b2/fp
      b3 = b3/fp
      b4 = b4/fp
      b5 = b5/fp
      b6 = b6/fp
      ! compute d eps/ d lambda
      de = SQRT( ((b1*b1+b2*b2+b3*b3)*2d0 + b4*b4+b5*b5+b6*b6)/3d0)  !d eps/ d lambda
      ap = gm*(2d0*(a1*b1+a2*b2+a3*b3)+a4*b4+a5*b5+a6*b6)+aprim*de
      dl = f0/ap
      ! new stres
      aux = dl*gm
      s11 = s11 - aux*b1*2d0
      s22 = s22 - aux*b2*2d0
      s33 = s33 - aux*b3*2d0
      s12 = s12 - aux*b4
      s13 = s13 - aux*b5
      s23 = s23 - aux*b6
      !   calculate the effective plastic strain
      epbar = epbar + dl*de
      !   update the radius of the yield surface
      yield = yield + aprim*dl*de

      !   calculate the effective stress
      a1 =  a(1)*s11 + a(2)*s22 + a(3)*s33
      a2 =  a(2)*s11 + a(4)*s22 + a(5)*s33
      a3 =  a(3)*s11 + a(5)*s22 + a(6)*s33
      a4 =  a(7)*s12
      a5 =  a(8)*s13
      a6 =  a(9)*s23
      fi = SQRT( a1*s11 + a2*s22 + a3*s33 + a4*s12 + a5*s13 + a6*s23 )
      f0 = fi-yield     !yield function
      !  IF consistency condition is satisfied exit loop
      flag =  ABS(f0/yield) <= toler1
      IF( flag )EXIT
    END DO

    IF( flag )THEN
      !  increment in plastic strains  (twice the deviatoric tensor)
      ep(1) = (st11 - s11)/gm
      ep(2) = (st22 - s22)/gm
      ep(3) = (st33 - s33)/gm
      ep(4) = (st12 - s12)/gm
      ep(5) = (st13 - s13)/gm
      ep(6) = (st23 - s23)/gm
      efpst = epbar - efpst              !increment in effective plastic strain
      !  assign corrected stresses
      st11 = s11
      st22 = s22
      st33 = s33
      st12 = s12
      st13 = s13
      st23 = s23
      !kk(k) = kk(k) + 1
      !k = SUM(kk)
      !IF( MOD(k,10000) == 0 )THEN
      !  WRITE(55,"(5i10)",ERR=9999) kk
      !  kk = 0
      !END IF
      IF( PRESENT(h) ) h = 1.3333d0*gm*(1d0-3d0*gm*(a3/fi)**2/(gm+2d0/3d0*aprim))
    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      ierr=1                               !set flag to error in plastic integration
    END IF
  END IF

  RETURN

 END SUBROUTINE corr18


      PROGRAM xwt1
C     driver for routine wt1
      INTEGER NCMAX,NMAX,NCEN,NWID
      PARAMETER(NMAX=512,NCMAX=50,NCEN=333,NWID=33)
      INTEGER i,itest,k,ncof,ioff,joff,nused
      REAL u(NMAX),v(NMAX),w(NMAX),cc,cr,frac,select,thresh,tmp
      COMMON /pwtcom/ cc(NCMAX),cr(NCMAX),ncof,ioff,joff
      EXTERNAL pwt,daub4
1     write(*,*) 'Enter k (4, -4, 12, or 20) and frac (0. to 1.):'
      read(*,*,END=999) k,frac
      frac=min(1.,max(0.,frac))
      if (k.eq.-4) then
        itest=1
      else
        itest=0
      endif
      k=abs(k)
      if (k.ne.4.and.k.ne.12.and.k.ne.20) goto 1
      do 11 i=1,NMAX
        if (i.gt.NCEN-NWID.and.i.lt.NCEN+NWID) then
          v(i)=float(i-NCEN+NWID)*float(NCEN+NWID-i)/NWID**2
        else
          v(i)=0.
        endif
        w(i)=v(i)
11    continue
      if (itest.eq.0) then
        call pwtset(k)
        call wt1(v,NMAX,1,pwt)
      else
        call wt1(v,NMAX,1,daub4)
      endif
      do 12 i=1,NMAX
        u(i)=abs(v(i))
12    continue
      thresh=select(int((1.-frac)*NMAX),NMAX,u)
      nused=0
      do 13 i=1,NMAX
        if (abs(v(i)).le.thresh) then
          v(i)=0.
        else
          nused=nused+1
        endif
13    continue
      if (itest.eq.0) then
        call wt1(v,NMAX,-1,pwt)
      else
        call wt1(v,NMAX,-1,daub4)
      endif
      thresh=0.
      do 14 i=1,NMAX
        tmp=abs(v(i)-w(i))
        if (tmp.gt.thresh) thresh=tmp
14    continue
      write(*,*) 'k,NMAX,nused=',k,NMAX,nused
      write(*,*) 'discrepancy=',thresh
      goto 1
999   END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xwt1.for


c   Gererate initial position and velocity for test particles
c   All of them have the same e and i.  The user supplies a range in a.
c   The tp are equally spaced in a.  The rest of the angles are chosen
c   at random.

      include 'swift.inc'

      real*8 SMASSYR
      parameter(SMASSYR=TWOPI*TWOPI)

      real*8 xht(NTPMAX),yht(NTPMAX),zht(NTPMAX)
      real*8 vxht(NTPMAX),vyht(NTPMAX),vzht(NTPMAX)

      real*8 gm,a,e,inc,capom,omega,capm,amin,amax,da
      real*8 ran,rstat(NTPMAX,NSTATR)
      real*8 cimax,imax

      integer istat(NTPMAX,NSTAT)
      integer ntp,ialpha,i,j,iseed,iuflg

      character*80 intpfile

 1    write(*,*) ' Units Menu: '
      write(*,*) '       0 ==> Solar masses, and AU '
      write(*,*) '       1 ==> AU, and Years '
      read(*,*) iuflg
      if( (iuflg.ne.0) .and. (iuflg.ne.1) ) goto 1

      write(*,*) ' Input number particles '
      read(*,*) ntp
      write(*,*) ' Input ecc of particles '
      read(*,*) e
      write(*,*) ' Input max inc of particles (in deg) '
      read(*,*) imax
      write(*,*) ' Input amin and amax '
      read(*,*) amin,amax
      da = (amax-amin)/float(ntp-1)

      write(*,*) ' Input iseed: large and odd '
      read(*,*) iseed

      a=amin
      cimax = cos(imax/DEGRAD)
      if(iuflg.eq.0) then
         gm = 1.0d0
      else
         gm = SMASSYR
      endif

      open(12,file='gen_ai.out')

      write(*,*) ' Test Paticles: '
      write(*,*) '   a      e      i    omega  capom    M '
      write(12,*) '   a      e      i    omega  capom    M '

      do i=1,ntp
         ialpha = -1
         inc = acos( 1.0d0 - (1.0d0-cimax)*ran(iseed))
         capm = TWOPI*ran(iseed)
         omega= TWOPI*ran(iseed)
         capom = TWOPI*ran(iseed)
         write(*,1000) a,e,inc,omega,capom,capm
         write(12,1000) a,e,inc,omega,capom,capm
 1000    format(6(1x,f6.3))

         call orbel_el2xv(gm,ialpha,a,e,inc,capom,omega,capm,
     &        xht(i),yht(i),zht(i),vxht(i),vyht(i),vzht(i))
         do j=1,NSTAT
            istat(i,j) = 0
         enddo
         do j=1,NSTATR
            rstat(i,j) = 0.0d0
         enddo
         a = a + da
      enddo

      write(*,*) 'Enter name of test particle data file : '
      read(*,1001) intpfile
 1001 format(a)
      call io_dump_tp(intpfile,ntp,xht,yht,zht,
     &     vxht,vyht,vzht,istat,rstat)

      stop
      end    !  gen_a

c-------------------------------------------------------------------------


subroutine SHRotateCoef(x, cof, rcof, dj, lmax)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will rotate a set of spherical harmonic coefficients (see
!	documentation in SHRotateRealCoef for a description of how rotation angles
!	are defined.) All angles are measured in radians, and spherical harmonic
!	coefficients are fully normalized as in Edmonds, 1960. Note that euler
!	angles are different in Goldstein and Edmonds.
!
!	This routine uses the "y-convention" where rotations are about the y axis
!	instead of the x axis.
!
!	djpi2 must be called before using this routine.
!
!	Calling Parameters
!		IN
!			x	Array of dimension 3 containing the three Euler angles.
!			dj	Roation matrix with dimension (lmax+1, lmax+1, lmax+1).
!			cof	Indexed spherical harmonic coefficients with dimensions
!				(2, (lmax+1)*(lmax+2)/2).
!			lmax	Maximum spherical harmonic degree.
!		OUT
!			rcof	Indexed rotated spherical harmonic coefficients with
!				dimensions (2, (lmax+1)*(lmax+2)/2).
!
!	Dependencies:	None
!
!	History:
!		1.	Based on routine from Guy Masters (July16, 1993)
!		2.	Modified by Mark Simons (July 25, 1993)
!		3.	Turned into readable f95 code by Mark Wieczorek (August, 2003)
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) :: 	cof(:,:), dj(:,:,:), x(3)
	real*8, intent(out) ::	rcof(:,:)
	integer, intent(in) :: lmax
	real*8 ::	sum(2), temp(2,lmax+1), temp2(2,lmax+1), cgam(lmax+1), sgam(lmax+1), &
			calf(lmax+1), salf(lmax+1), cbet(lmax+1), sbet(lmax+1), pi2, alpha, &
			beta, gamma
	integer ::	ind, lp1, l, mp1, jp1, isgn, ii, indx

	if (size(cof(:,1)) < 2 .or. size(cof(1,:)) < (lmax+1)*(lmax+2)/2) then
		print*, "Error --- SHRotateCoef"
		print*, "COEF must be dimensioned (2, (LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
		print*, "Input array is dimensioned ", size(cof(:,1)),  size(cof(1,:))
		stop
	elseif (size(rcof(:,1)) < 2 .or. size(rcof(1,:)) < (lmax+1)*(lmax+2)/2) then
		print*, "Error --- SHRotateCoef"
		print*, "RCOEF must be dimensioned (2, (LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
		print*, "Input array is dimensioned ", size(rcof(:,1)),  size(rcof(1,:))
		stop
	elseif (size(dj(:,1,1)) < lmax+1 .or. size(dj(1,:,1)) < lmax+1 .or. size(dj(1,1,:)) < lmax+1 ) then
		print*, "Error --- SHRotateCoef"
		print*, "DJ must be dimensioned (LMAX+1, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned ", size(dj(:,1,1)), size(dj(1,:,1)), size(dj(1,1,:))
		stop
	endif

	pi2 = 1.570796326794895d0

	alpha = x(1)
	beta  = x(2)
	gamma = x(3)

	alpha = alpha-pi2
	gamma = gamma+pi2
	beta = -beta

	ind = 0

	! Loop over degrees

	do lp1 = 1, lmax+1
		l = lp1-1
		cbet(lp1) = cos(l*beta)
		sbet(lp1) = sin(l*beta)
		cgam(lp1) = cos(l*gamma)
		sgam(lp1) = sin(l*gamma)
		calf(lp1) = cos(l*alpha)
		salf(lp1) = sin(l*alpha)

		! Alpha rotation

		do mp1 = 1, lp1
			indx = ind+mp1
			temp(1,mp1) = cof(1,indx) * calf(mp1) - cof(2,indx) * salf(mp1)
			temp(2,mp1) = cof(2,indx) * calf(mp1) + cof(1,indx) * salf(mp1)
		enddo

		! B rotation and beta rotation

		do jp1 = 1, lp1
			sum(1) = dj(jp1,1,lp1)*temp(1,1)
			sum(2) = 0.d0
			isgn = 1-2*mod((lp1-jp1),2)

			do mp1 = 2, lp1
				isgn = -isgn
				ii = (3-isgn)/2
				sum(ii) = sum(ii)+2.d0*dj(jp1,mp1,lp1)*temp(ii,mp1)
			enddo

			temp2(1,jp1) = sum(1)*cbet(jp1)-sum(2)*sbet(jp1)
			temp2(2,jp1) = sum(2)*cbet(jp1)+sum(1)*sbet(jp1)

		enddo

		! Inverse B rotation and gamma rotation

		do jp1 = 1, lp1

			sum(1) = dj(1,jp1,lp1)*temp2(1,1)
			sum(2) = 0.d0
			isgn = 1-2*mod((lp1-jp1),2)

			do mp1 = 2,lp1
				isgn = -isgn
				ii = (3-isgn)/2
				sum(ii) = sum(ii)+2.d0*dj(mp1,jp1,lp1)*temp2(ii,mp1)
			enddo

			indx = ind+jp1
			rcof(1,indx) = sum(1)*cgam(jp1)-sum(2)*sgam(jp1)
			rcof(2,indx) = sum(2)*cgam(jp1)+sum(1)*sgam(jp1)

		enddo

		ind = ind+lp1

	enddo

end subroutine SHRotateCoef


#version 130

#include "lib.h"

in vec2 p;

// misc functions {{{
vec3 bool2col(bool b) {
    return b? vec3(0.5, 0.5, 1.0): vec3(1.);
}

bool eq(float x, float y, float t) {
    return (x+t > y) && (x-t < y);
}

ivec2 hexagon(vec2 p) {
    p.y -= 1/sqrt(3);
    vec2 c = vec2(1,1/sqrt(3));

    ivec2 q = ivec2(floor(p/c));
    vec2 d = p - q*c;

    bool q1 = d.x*c.y + d.y*c.x >= c.x*c.y;
    bool q2 = (c.x-d.x)*c.y + d.y * c.x >= c.x*c.y;
    ivec2 r = ivec2(floor(q.x/2.),floor(q.y/3.));
    switch(imod(q.y, 6)) {
    case 0:
        if(q.x%2 == 0) {
            if(!q1) {r.x--;r.y--;}
        } else {
            if(!q2) r.y--;
        }
        break;
    case 3:
        if(q.x%2 == 0) {
            if(q2) r.x--;
            else r.y--;
        } else {
            if(!q1) r.y--;
        }
        break;
    case 4:case 5:
        r.x = int(floor((q.x+1)/2.))-1;
        break;
    }
    return r;
}
// }}}

// patterns {{{
float grid_f(float x, float period) {
    const float TRESHOLD = 0.99;
    float val = abs(sin(TAU*(x+1.0)*0.5*period));
    return val >= TRESHOLD ? 1.0 : 0.0;
}
vec3 pattern_grid(vec2 p) {
    float val = (grid_f(p.x, 8) + grid_f(p.y, 8))/2;
    return vec3(1.0-val, 1.0-val, 1.0);
}

uniform int px = 0, py = 0;
#pragma machuchu slider px -100 100
#pragma machuchu slider py -100 100
vec3 pattern_sight(vec2 p) {
    vec2 c = vec2(px, py)/100.;
    return bool2col(eq(p.x,c.x, 0.01) || eq(p.y,c.y, 0.01));
}

uniform int scale = 10;
#pragma machuchu slider scale 1 30

vec3 pattern_checkboard(vec2 p) {
    return bool2col(bxor2(lessThan(fract(p*scale), vec2(0.5))));
}

vec3 pattern_gingham(vec2 p) {
    ivec2 q = ivec2(floor(p*scale*2));
    int i = imod(q.x,2)+imod(q.y,2);
    switch(i){
    case 0: return vec3(1,1,1);
    case 1: return vec3(0.75,0.75,1);
    case 2: return vec3(0.5,0.5,1);
    }
}

vec3 pattern_hexagonal(vec2 p) {
    ivec2 q = hexagon(p*scale*3);
    int i = q.x - (q.y&1) + 1;
    switch(imod(i,3)){
    case 0: return vec3(1,1,1);
    case 1: return vec3(0.75,0.75,1);
    case 2: return vec3(0.5,0.5,1);
    }
}

uniform int pattern = 0;
#pragma machuchu slider pattern 0 4
vec3 pattern_(vec2 p) {
    switch(pattern) {
    case 0: return pattern_grid(p);
    case 1: return pattern_sight(p);
    case 2: return pattern_checkboard(p);
    case 3: return pattern_gingham(p);
    case 4: return pattern_hexagonal(p);
    }
}
// }}}

// transofrmations {{{
vec2 transform1(vec2 i) {
    return vec2(atan(i.x,i.y)/PI, log(sqr(i.x)+sqr(i.y))/PI/2 );
}

uniform int transform = 0;
#pragma machuchu slider transform 0 2
vec2 transform_(vec2 i) {
    switch(transform) {
    case 0: return i;
    case 1: return transform1(i);
    case 2: return cx_inv(i);
    }
}
// }}}

void main() {
    gl_FragColor = vec4(pattern_(transform_(p)), 1.0);
}


      SUBROUTINE AUSPECF(N,LAGH1,CXX1,P1,P2,Q)
C

C
C     PROGRAM 5.2.1   POWER SPECTRUM
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C        TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C        "DAINAMIKKU SISTEMU NO TOKEI-TEKI KAISEKI TO SEIGYO (STATISTICA
C        ANALYSIS AND CONTROL OF DYNAMIC SYSTEMS)" BY H. AKAIKE AND
C        T. NAKAGAWA, SAIENSU-SHA, TOKYO, 1972 (IN JAPANESE)
C-----------------------------------------------------------------------
C     THIS PROGRAM COMPUTES POWER SPECTRUM ESTIMATES FOR TWO
C     TRIGONOMETRIC WINDOWS OF BLACKMAN-TUKEY TYPE BY GOERTZEL METHOD.
C     ONLY ONE CARD OF LAGH(MAXIMUM LAG OF COVARIANCES TO BE USED FOR
C     POWER SPECTRUM COMPUTATION) SHOULD BE ADDED ON TOP OF THE OUTPUT
C     OF PROGRAM 5.1.1 AUTCOR TO FORM INPUT TO THIS PROGRAM.
C     OUTPUTS ARE ESTIMATES P1(I),P2(I) FOR FREQUENCIES I/(2LAGH*DELTAT)
C     AND THE TEST STATISTICS Q(I) FOR THE DIFFERENCES BETWEEN P1(I) AND
C     P2(I).   Q(I) GREATER THAN 1 MEANS SIGNIFICANT DIFFERENCE.
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: AUSPECF
c      USE DFLIB
C
cxx      IMPLICIT REAL*8(A-H,O-Z)
c      DIMENSION CXX(1001),FC(1001),P1(1001),P2(1001),Q(1001)
c      DIMENSION A1(10),A2(10)
cxx      DIMENSION CXX1(LAGH1),CXX(LAGH1)
cxx      DIMENSION FC(LAGH1),P1(LAGH1),P2(LAGH1),Q(LAGH1)
cxx      DIMENSION A1(2),A2(3)
      INTEGER :: N, LAGH1
      REAL(8) :: CXX1(LAGH1), P1(LAGH1), P2(LAGH1), Q(LAGH1)
      REAL(8) :: CXX(LAGH1), FC(LAGH1), A1(2), A2(3)
C
C     INPUT / OUTPUT DATA FILE OPEN
c	CHARACTER(100) DFNAM
c	DFNAM='auspec.out'
c	CALL SETWND
c	CALL FLOPN3(DFNAM,NFL)
c	IF (NFL.EQ.0) GO TO 999
C
C     WINDOW W1 DEFINITION
      MLA1=2
      A1(1)=0.5D-00
      A1(2)=0.25D-00
C     WINDOW W2 DEFINITION
      MLA2=3
      A2(1)=0.625D-00
      A2(2)=0.25D-00
      A2(3)=-0.0625D-00
C
C     LAGH SPECIFICATION
c      READ(5,1) LAGH
c      LAGH1=LAGH+1
C     READING THE OUTPUTS OF PROGRAM 5.1.1 AUTCOR
c      READ(5,1) N,LAGH0
c      LAGH3=LAGH0+1
C     INITIAL CONDITION PRINT OUT
c      WRITE(6,60)
c      WRITE(6,61)
c      WRITE(6,62) N,LAGH
c      WRITE(6,63)
c      CALL PRCOL1(A1,1,MLA1,1)
c      WRITE(6,64)
c      CALL PRCOL1(A2,1,MLA2,1)
C     AUTO COVARIANCE INPUT
c      READ(5,2) (CXX(I),I=1,LAGH3)
C     AUTO COVARIANCE PRINT OUT
c      WRITE(6,172)
c      WRITE(6,162)
c      CALL PRCOL1(CXX,1,LAGH1,1)
c      DO 10 I=2,LAGH
c   10 CXX(I)=CXX(I)+CXX(I)
      CXX(1)=CXX1(1)
      DO 10 I=2,LAGH1-1
cxx   10 CXX(I)=CXX1(I)+CXX1(I)
      CXX(I)=CXX1(I)+CXX1(I)
   10 CONTINUE
      CXX(LAGH1)=CXX1(LAGH1)
C     F-COS TRANSFORMATION
      CALL FGERCO(CXX,LAGH1,FC,LAGH1)
C     SPECTRUM SMOOTHING BY WINDOW W1
      CALL AUSP(FC,P1,LAGH1,A1,MLA1)
C     SPECTRUM SMOOTHING BY WINDOW W2
      CALL AUSP(FC,P2,LAGH1,A2,MLA2)
C     TEST STATISTICS COMPUTATION
      CALL SIGNIF(P1,P2,Q,LAGH1,N)
C     AUTO SPECTRUM AND TEST STATISTICS PRINT OUT
c      WRITE(6,66) N,LAGH
c      WRITE(6,67)
c      CALL PRCOL3(P1,P2,Q,1,LAGH1,1)
C     AUTO SPECTRUM SMOOTHED BY WINDOW W1 PUNCH OUT
c      WRITE(7,1) N,LAGH
c      WRITE(7,2) (P1(I),I=1,LAGH1)
c	CALL FLCLS3(NFL)
c    1 FORMAT(10I5)
c    2 FORMAT(4D20.10)
c   60 FORMAT(1H ,30HPROGRAM 5.2.1   POWER SPECTRUM)
c   62 FORMAT(1H ,2HN=,I5,5X,5HLAGH=,I5)
c   61 FORMAT(1H ,17HINITIAL CONDITION)
c   63 FORMAT(1H ,12X,9HWINDOW W1/1H ,4X,1HI,11X,5HA1(I))
c   64 FORMAT(1H ,12X,9HWINDOW W2/1H ,4X,1HI,11X,5HA2(I))
c   66 FORMAT(//1H ,14HPOWER SPECTRUM,5X,2HN=,I5,5X,5HLAGH=,I5)
c   67 FORMAT(1H ,4X,1HI,8X,8HPOWER W1,6X,8HPOWER W2,2X,12HSIGNIFICANCE)
c  162 FORMAT(1H ,4X,1HI,6X,6HCXX(I))
c  172 FORMAT(1H ,5X,15HAUTO COVARIANCE)
      RETURN
      END SUBROUTINE


*DECK DPFQAD
      SUBROUTINE DPFQAD (F, LDC, C, XI, LXI, K, ID, X1, X2, TOL, QUAD,
     +   IERR)
C***BEGIN PROLOGUE  DPFQAD
C***PURPOSE  Compute the integral on (X1,X2) of a product of a
C            function F and the ID-th derivative of a B-spline,
C            (PP-representation).
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      DOUBLE PRECISION (PFQAD-S, DPFQAD-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract    **** a double precision routine ****
C         DPFQAD computes the integral on (X1,X2) of a product of a
C         function F and the ID-th derivative of a B-spline, using the
C         PP-representation (C,XI,LXI,K).  (X1,X2) is normally a sub-
C         interval of XI(1) .LE. X .LE. XI(LXI+1).  An integration
C         routine, DPPGQ8 (a modification of GAUS8), integrates the
C         product on subintervals of (X1,X2) formed by the included
C         break points.  Integration outside of (XI(1),XI(LXI+1)) is
C         permitted provided F is defined.
C
C         The maximum number of significant digits obtainable in
C         DBSQAD is the smaller of 18 and the number of digits
C         carried in double precision arithmetic.
C
C     Description of arguments
C         Input      F,C,XI,X1,X2,TOL are double precision
C           F      - external function of one argument for the
C                    integrand PF(X)=F(X)*DPPVAL(LDC,C,XI,LXI,K,ID,X,
C                    INPPV)
C           LDC    - leading dimension of matrix C, LDC .GE. K
C           C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI
C           XI(*)  - break point array of length LXI+1
C           LXI    - number of polynomial pieces
C           K      - order of B-spline, K .GE. 1
C           ID     - order of the spline derivative, 0 .LE. ID .LE. K-1
C                    ID=0 gives the spline function
C           X1,X2  - end points of quadrature interval, normally in
C                    XI(1) .LE. X .LE. XI(LXI+1)
C           TOL    - desired accuracy for the quadrature, suggest
C                    10.*DTOL .LT. TOL .LE. 0.1 where DTOL is the
C                    maximum of 1.0D-18 and double precision unit
C                    roundoff for the machine = D1MACH(4)
C
C         Output     QUAD is double precision
C           QUAD   - integral of PF(X) on (X1,X2)
C           IERR   - a status code
C                    IERR=1 normal return
C                         2 some quadrature does not meet the
C                           requested tolerance
C
C     Error Conditions
C         Improper input is a fatal error.
C         Some quadrature does not meet the requested tolerance.
C
C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
C                 B-splines, Report SAND79-1825, Sandia Laboratories,
C                 December 1979.
C***ROUTINES CALLED  D1MACH, DINTRV, DPPGQ8, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPFQAD
C
      INTEGER ID,IERR,IFLG,ILO,IL1,IL2,INPPV,K,LDC,LEFT,LXI,MF1,MF2
      DOUBLE PRECISION A,AA,ANS,B,BB,C,Q,QUAD,TA,TB,TOL,WTOL,XI,X1,X2
      DOUBLE PRECISION D1MACH, F
      DIMENSION XI(*), C(LDC,*)
      EXTERNAL F
C
C***FIRST EXECUTABLE STATEMENT  DPFQAD
      IERR = 1
      QUAD = 0.0D0
      IF(K.LT.1) GO TO 100
      IF(LDC.LT.K) GO TO 105
      IF(ID.LT.0 .OR. ID.GE.K) GO TO 110
      IF(LXI.LT.1) GO TO 115
      WTOL = D1MACH(4)
      WTOL = MAX(WTOL,1.0D-18)
      IF (TOL.LT.WTOL .OR. TOL.GT.0.1D0) GO TO 20
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.EQ.BB) RETURN
      ILO = 1
      CALL DINTRV(XI, LXI, AA, ILO, IL1, MF1)
      CALL DINTRV(XI, LXI, BB, ILO, IL2, MF2)
      Q = 0.0D0
      INPPV = 1
      DO 10 LEFT=IL1,IL2
        TA = XI(LEFT)
        A = MAX(AA,TA)
        IF (LEFT.EQ.1) A = AA
        TB = BB
        IF (LEFT.LT.LXI) TB = XI(LEFT+1)
        B = MIN(BB,TB)
        CALL DPPGQ8(F,LDC,C,XI,LXI,K,ID,A,B,INPPV,TOL,ANS,IFLG)
        IF (IFLG.GT.1) IERR = 2
        Q = Q + ANS
   10 CONTINUE
      IF (X1.GT.X2) Q = -Q
      QUAD = Q
      RETURN
C
   20 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD',
     +   'TOL IS LESS DTOL OR GREATER THAN 0.1', 2, 1)
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD',
     +   'ID DOES NOT SATISFY 0.LE.ID.LT.K', 2, 1)
      RETURN
  115 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD', 'LXI DOES NOT SATISFY LXI.GE.1',
     +   2, 1)
      RETURN
      END


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


    MODULE random_standard_uniform_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

!*********************************************************************

      FUNCTION random_standard_uniform()
! .. Use Statements ..
        USE ecuyer_cote_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_standard_uniform
! ..
! .. Executable Statements ..

!----------------------------------------------------------------------
!     REAL FUNCTION random_standard_uniform()
!     Returns a random floating point number from a uniform distribution
!     over 0 - 1 (endpoints of this interval are not returned) using the
!     current generator
!     This is a transcription from Pascal to Fortran of routine
!     Uniform_01 from the paper
!     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
!     with Splitting Facilities." ACM Transactions on Mathematical
!     Software, 17:98-111 (1991)
!----------------------------------------------------------------------
!     4.656613057E-10 is 1/M1  M1 is set in a data statement in
!     random_large_integer
!      and is currently 2147483563. If M1 changes, change this also.
        random_standard_uniform = random_large_integer()*4.656613057E-10
        RETURN

      END FUNCTION random_standard_uniform

!*********************************************************************

    END MODULE random_standard_uniform_mod


SUBROUTINE p611(input_file,output_file)
!-------------------------------------------------------------------------
! Program 6.11 Axisymmetric `undrained' strain of an elastic-plastic
!             (Mohr-Coulomb) solid using 8-node rectangular
!             quadrilaterals. Viscoplastic strain method.
!-------------------------------------------------------------------------
 USE main
 USE geom
  IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,incs,iters,iy,k,limit,ndim=2,ndof=16,nels, &
   neq,nip=4,nlen,nn,nod=8,nodof=2,nr,nst=4,nxe,nye
 REAL(iwp)::bulk,c,cons,det,dq1,dq2,dq3,dsbar,dt,d4=4.0_iwp,              &
   d180=180.0_iwp,e,f,lode_theta,one=1.0_iwp,phi,pi,presc,psi,sigm,snph,  &
   penalty=1.e20_iwp,tol,two=2.0_iwp,v,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 LOGICAL::converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:),no(:),    &
   node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::bdylds(:),bee(:,:),bload(:),coord(:,:),dee(:,:),  &
   der(:,:),deriv(:,:),devp(:),eld(:),eload(:),eps(:),erate(:),           &
   etensor(:,:,:),evp(:),evpt(:,:,:),flow(:,:),fun(:),gc(:),g_coord(:,:), &
   jac(:,:),km(:,:),kv(:),loads(:),m1(:,:),m2(:,:),m3(:,:),oldis(:),      &
   points(:,:),pore(:,:),sigma(:),storkv(:),stress(:),tensor(:,:,:),      &
   totd(:),weights(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,phi,c,psi,e,v,bulk,cons
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   x_coords(nxe+1),y_coords(nye+1),num(nod),evpt(nst,nip,nels),           &
   coord(nod,ndim),g_g(ndof,nels),tensor(nst,nip,nels),fun(nod),          &
   etensor(nst,nip,nels),dee(nst,nst),pore(nip,nels),stress(nst),         &
   jac(ndim,ndim),der(ndim,nod),deriv(ndim,nod),g_num(nod,nels),          &
   bee(nst,ndof),km(ndof,ndof),eld(ndof),eps(nst),sigma(nst),bload(ndof), &
   eload(ndof),erate(nst),evp(nst),devp(nst),g(ndof),m1(nst,nst),         &
   m2(nst,nst),m3(nst,nst),flow(nst,nst),gc(ndim))
 READ(10,*)x_coords,y_coords
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),bdylds(0:neq),oldis(0:neq),totd(0:neq))
!-----------------------loop the elements to find global arrays sizes-----
 kdiag=0
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I7))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------add fluid bulk modulus effective dee matrix-------
 CALL deemat(dee,e,v)
 pi=ACOS(-one)
 DO i=1,nst
 DO k=1,nst
   IF(i/=3.AND.k/=3)dee(i,k)=dee(i,k)+bulk
 END DO
 END DO
 snph=SIN(phi*pi/d180)
 dt=d4*(one+ v)*(one-two*v)/(e*(one-two*v+snph*snph))
 CALL sample(element,points,weights)
 kv=zero
 tensor=zero
 etensor=zero
!-----------------------element stiffness integration and assembly--------
 elements_2: DO iel=1,nels
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL bee8(bee,coord,points(i,1),points(i,2),det)
     gc=MATMUL(fun,coord)
     bee(4,1:ndof-1:2)=fun(:)/gc(1)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)*gc(1)
     tensor(1:2,i,iel)=cons
     tensor(4,i,iel)=cons
   END DO gauss_pts_1
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
!-----------------------read displacement data and factorise equations----
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),sense(fixed_freedoms),no(fixed_freedoms),&
     storkv(fixed_freedoms))
   READ(10,*)(node(i),sense(i),i=1,fixed_freedoms)
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   storkv=kv(kdiag(no))
 END IF
 CALL sparin(kv,kdiag)
 CALL deemat(dee,e,v)
!-----------------------displacement increment loop-----------------------
 READ(10,*)tol,limit,incs,presc
 WRITE(11,'(/A)')"  step   disp      dev stress  pore press  iters"
 oldis=zero
 totd=zero
 disp_incs: DO iy=1,incs
   iters=0
   bdylds=zero
   evpt=zero
!-----------------------plastic iteration loop----------------------------
   its: DO
     iters=iters+1
     WRITE(*,'(A,E11.3,A,I4)')"  displacement",iy*presc,"  iteration",iters
     loads=zero
     loads(no)=storkv*presc
     loads=loads+bdylds
     CALL spabac(kv,loads,kdiag)
!-----------------------check plastic convergence-------------------------
     CALL checon(loads,oldis,tol,converged)
     IF(iters==1)converged=.FALSE.
!-----------------------go round the Gauss points ------------------------
     elements_3: DO iel=1,nels
       bload=zero
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       eld=loads(g)
       gauss_pts_2: DO i=1,nip
         CALL shape_fun(fun,points,i)
         CALL bee8(bee,coord,points(i,1),points(i,2),det)
         gc=MATMUL(fun,coord)
         bee(4,1:ndof-1:2)=fun(:)/gc(1)
         eps=MATMUL(bee,eld)
         eps=eps-evpt(:,i,iel)
         sigma=MATMUL(dee,eps)
         stress=sigma+tensor(:,i,iel)
         CALL invar(stress,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         CALL mocouf(phi,c,sigm,dsbar,lode_theta,f)
         IF(f>=zero)THEN
           CALL mocouq(psi,dsbar,lode_theta,dq1,dq2,dq3)
           CALL formm(stress,m1,m2,m3)
           flow=f*(m1*dq1+m2*dq2+m3*dq3)
           erate=MATMUL(flow,stress)
           evp=erate*dt
           evpt(:,i,iel)=evpt(:,i,iel)+evp
           devp=MATMUL(dee,evp)
           eload=MATMUL(devp,bee)
           bload=bload+eload*det*weights(i)*gc(1)
         END IF
!------update the Gauss Point stresses and calculate pore pressures-------
         IF(converged.OR.iters==limit)THEN
           tensor(:,i,iel)=stress
           etensor(:,i,iel)=etensor(:,i,iel)+eps+evpt(:,i,iel)
           pore(i,iel)=(etensor(1,i,iel)+etensor(2,i,iel)+                &
             etensor(4,i,iel))*bulk
         END IF
       END DO gauss_pts_2
!-----------------------compute the total bodyloads vector ---------------
       bdylds(g)=bdylds(g)+bload
       bdylds(0)=zero
     END DO elements_3
     IF(converged.OR.iters==limit)EXIT
   END DO its
   totd=totd+loads
   WRITE(11,'(I5,3E12.4,I5)')iy,totd(no(1)),dsbar, pore(1,1),iters
   IF(iters==limit)EXIT
 END DO disp_incs
 CALL dismsh(loads,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(loads,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p611


      SUBROUTINE JACOBI (A,B,X,EIGV,D,N,RTOL,NSMAX,IFPR,IOUT)           JAC00001
C ..................................................................... JAC00002
C .                                                                   . JAC00003
C .   P R O G R A M                                                   . JAC00004
C .        TO SOLVE THE GENERALIZED EIGENPROBLEM USING THE            . JAC00005
C .        GENERALIZED JACOBI ITERATION                               . JAC00006
C .                                                                   . JAC00007
C . - - INPUT VARIABLES - -                                           . JAC00008
C .        A(N,N)    = STIFFNESS MATRIX (ASSUMED POSITIVE DEFINITE)   . JAC00009
C .        B(N,N)    = MASS MATRIX (ASSUMED POSITIVE DEFINITE)        . JAC00010
C .        X(N,N)    = STORAGE FOR EIGENVECTORS                       . JAC00011
C .        EIGV(N)   = STORAGE FOR EIGENVALUES                        . JAC00012
C .        D(N)      = WORKING VECTOR                                 . JAC00013
C .        N         = ORDER OF MATRICES A AND B                      . JAC00014
C .        RTOL      = CONVERGENCE TOLERANCE (USUALLY SET TO 10.**-12). JAC00015
C .        NSMAX     = MAXIMUM NUMBER OF SWEEPS ALLOWED               . JAC00016
C .                                  (USUALLY SET TO 15)              . JAC00017
C .        IFPR      = FLAG FOR PRINTING DURING ITERATION             . JAC00018
C .            EQ.0    NO PRINTING                                    . JAC00019
C .            EQ.1    INTERMEDIATE RESULTS ARE PRINTED               . JAC00020
C .        IOUT      = UNIT NUMBER USED FOR OUTPUT                    . JAC00021
C .                                                                   . JAC00022
C . - - OUTPUT - -                                                    . JAC00023
C .        A(N,N)    = DIAGONALIZED STIFFNESS MATRIX                  . JAC00024
C .        B(N,N)    = DIGONALIZED MASS MATRIX                        . JAC00025
C .        X(N,N)    = EIGENVECTORS STORED COLUMNWISE                 . JAC00026
C .        EIGV(N)   = EIGENVALUES                                    . JAC00027
C .                                                                   . JAC00028
C ..................................................................... JAC00029
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)                               JAC00030
C ..................................................................... JAC00031
C .   THIS PROGRAM IS USED IN SINGLE PRECISION ARITHMETIC ON CRAY     . JAC00032
C .   EQUIPMENT AND DOUBLE PRECISION ARITHMETIC ON IBM MACHINES,      . JAC00033
C .   ENGINEERING WORKSTATIONS AND PCS. DEACTIVATE ABOVE LINE FOR     . JAC00034
C .   SINGLE PRECISION ARITHMETIC.                                    . JAC00035
C ..................................................................... JAC00036
      DIMENSION A(N,N),B(N,N),X(N,N),EIGV(N),D(N)                       JAC00037
C                                                                       JAC00038
C     INITIALIZE EIGENVALUE AND EIGENVECTOR MATRICES                    JAC00039
C                                                                       JAC00040
      DO 10 I=1,N                                                       JAC00041
      IF (A(I,I).GT.0. .AND. B(I,I).GT.0.) GO TO 4                      JAC00042
      WRITE (IOUT,2020)                                                 JAC00043
      GO TO 800                                                         JAC00044
    4 D(I)=A(I,I)/B(I,I)                                                JAC00045
   10 EIGV(I)=D(I)                                                      JAC00046
      DO 30 I=1,N                                                       JAC00047
      DO 20 J=1,N                                                       JAC00048
   20 X(I,J)=0.                                                         JAC00049
   30 X(I,I)=1.                                                         JAC00050
      IF (N.EQ.1) GO TO 900                                             JAC00051
C                                                                       JAC00052
C     INITIALIZE SWEEP COUNTER AND BEGIN ITERATION                      JAC00053
C                                                                       JAC00054
      NSWEEP=0                                                          JAC00055
      NR=N - 1                                                          JAC00056
   40 NSWEEP=NSWEEP + 1                                                 JAC00057
      IF (IFPR.EQ.1) WRITE (IOUT,2000) NSWEEP                           JAC00058
C                                                                       JAC00059
C     CHECK IF PRESENT OFF-DIAGONAL ELEMENT IS LARGE ENOUGH TO          JAC00060
C     REQUIRE ZEROING                                                   JAC00061
C                                                                       JAC00062
      EPS=(.01)**(NSWEEP*2)                                             JAC00063
      DO 210 J=1,NR                                                     JAC00064
      JJ=J + 1                                                          JAC00065
      DO 210 K=JJ,N                                                     JAC00066
      EPTOLA=(A(J,K)/A(J,J))*(A(J,K)/A(K,K))                            JAC00067
      EPTOLB=(B(J,K)/B(J,J))*(B(J,K)/B(K,K))                            JAC00068
      IF (EPTOLA.LT.EPS .AND. EPTOLB.LT.EPS) GO TO 210                  JAC00069
C                                                                       JAC00070
C     IF ZEROING IS REQUIRED, CALCULATE THE ROTATION MATRIX             JAC00071
C     ELEMENTS CA AND CG                                                JAC00072
C                                                                       JAC00073
      AKK=A(K,K)*B(J,K) - B(K,K)*A(J,K)                                 JAC00074
      AJJ=A(J,J)*B(J,K) - B(J,J)*A(J,K)                                 JAC00075
      AB=A(J,J)*B(K,K) - A(K,K)*B(J,J)                                  JAC00076
      SCALE=A(K,K)*B(K,K)                                               JAC00077
      ABCH=AB/SCALE                                                     JAC00078
      AKKCH=AKK/SCALE                                                   JAC00079
      AJJCH=AJJ/SCALE                                                   JAC00080
      CHECK=(ABCH*ABCH + 4.*AKKCH*AJJCH)/4.                             JAC00081
      IF (CHECK) 50,60,60                                               JAC00082
   50 WRITE (IOUT,2020)                                                 JAC00083
      GO TO 800                                                         JAC00084
   60 SQCH=SCALE*SQRT(CHECK)                                            JAC00085
      D1=AB/2. + SQCH                                                   JAC00086
      D2=AB/2. - SQCH                                                   JAC00087
      DEN=D1                                                            JAC00088
      IF (ABS(D2).GT.ABS(D1)) DEN=D2                                    JAC00089
      IF (DEN) 80,70,80                                                 JAC00090
   70 CA=0.                                                             JAC00091
      CG=-A(J,K)/A(K,K)                                                 JAC00092
      GO TO 90                                                          JAC00093
   80 CA=AKK/DEN                                                        JAC00094
      CG=-AJJ/DEN                                                       JAC00095
C                                                                       JAC00096
C     PERFORM THE GENERALIZED ROTATION TO ZERO ELEMENTS                 JAC00097
C                                                                       JAC00098
   90 IF (N-2) 100,190,100                                              JAC00099
  100 JP1=J + 1                                                         JAC00100
      JM1=J - 1                                                         JAC00101
      KP1=K + 1                                                         JAC00102
      KM1=K - 1                                                         JAC00103
      IF (JM1-1) 130,110,110                                            JAC00104
  110 DO 120 I=1,JM1                                                    JAC00105
      AJ=A(I,J)                                                         JAC00106
      BJ=B(I,J)                                                         JAC00107
      AK=A(I,K)                                                         JAC00108
      BK=B(I,K)                                                         JAC00109
      A(I,J)=AJ + CG*AK                                                 JAC00110
      B(I,J)=BJ + CG*BK                                                 JAC00111
      A(I,K)=AK + CA*AJ                                                 JAC00112
  120 B(I,K)=BK + CA*BJ                                                 JAC00113
  130 IF (KP1-N) 140,140,160                                            JAC00114
  140 DO 150 I=KP1,N                                                    JAC00115
      AJ=A(J,I)                                                         JAC00116
      BJ=B(J,I)                                                         JAC00117
      AK=A(K,I)                                                         JAC00118
      BK=B(K,I)                                                         JAC00119
      A(J,I)=AJ + CG*AK                                                 JAC00120
      B(J,I)=BJ + CG*BK                                                 JAC00121
      A(K,I)=AK + CA*AJ                                                 JAC00122
  150 B(K,I)=BK + CA*BJ                                                 JAC00123
  160 IF (JP1-KM1) 170,170,190                                          JAC00124
  170 DO 180 I=JP1,KM1                                                  JAC00125
      AJ=A(J,I)                                                         JAC00126
      BJ=B(J,I)                                                         JAC00127
      AK=A(I,K)                                                         JAC00128
      BK=B(I,K)                                                         JAC00129
      A(J,I)=AJ + CG*AK                                                 JAC00130
      B(J,I)=BJ + CG*BK                                                 JAC00131
      A(I,K)=AK + CA*AJ                                                 JAC00132
  180 B(I,K)=BK + CA*BJ                                                 JAC00133
  190 AK=A(K,K)                                                         JAC00134
      BK=B(K,K)                                                         JAC00135
      A(K,K)=AK + 2.*CA*A(J,K) + CA*CA*A(J,J)                           JAC00136
      B(K,K)=BK + 2.*CA*B(J,K) + CA*CA*B(J,J)                           JAC00137
      A(J,J)=A(J,J) + 2.*CG*A(J,K) + CG*CG*AK                           JAC00138
      B(J,J)=B(J,J) + 2.*CG*B(J,K) + CG*CG*BK                           JAC00139
      A(J,K)=0.                                                         JAC00140
      B(J,K)=0.                                                         JAC00141
C                                                                       JAC00142
C     UPDATE THE EIGENVECTOR MATRIX AFTER EACH ROTATION                 JAC00143
C                                                                       JAC00144
      DO 200 I=1,N                                                      JAC00145
      XJ=X(I,J)                                                         JAC00146
      XK=X(I,K)                                                         JAC00147
      X(I,J)=XJ + CG*XK                                                 JAC00148
  200 X(I,K)=XK + CA*XJ                                                 JAC00149
  210 CONTINUE                                                          JAC00150
C                                                                       JAC00151
C     UPDATE THE EIGENVALUES AFTER EACH SWEEP                           JAC00152
C                                                                       JAC00153
      DO 220 I=1,N                                                      JAC00154
      IF (A(I,I).GT.0. .AND. B(I,I).GT.0.) GO TO 220                    JAC00155
      WRITE (IOUT,2020)                                                 JAC00156
      GO TO 800                                                         JAC00157
  220 EIGV(I)=A(I,I)/B(I,I)                                             JAC00158
      IF (IFPR.EQ.0) GO TO 230                                          JAC00159
      WRITE (IOUT,2030)                                                 JAC00160
      WRITE (IOUT,2010) (EIGV(I),I=1,N)                                 JAC00161
C                                                                       JAC00162
C     CHECK FOR CONVERGENCE                                             JAC00163
C                                                                       JAC00164
  230 DO 240 I=1,N                                                      JAC00165
      TOL=RTOL*D(I)                                                     JAC00166
      DIF=ABS(EIGV(I)-D(I))                                             JAC00167
      IF (DIF.GT.TOL) GO TO 280                                         JAC00168
  240 CONTINUE                                                          JAC00169
C                                                                       JAC00170
C     CHECK OFF-DIAGONAL ELEMENTS TO SEE IF ANOTHER SWEEP IS NEEDED     JAC00171
C                                                                       JAC00172
      EPS=RTOL**2                                                       JAC00173
      DO 250 J=1,NR                                                     JAC00174
      JJ=J + 1                                                          JAC00175
      DO 250 K=JJ,N                                                     JAC00176
      EPSA=(A(J,K)/A(J,J))*(A(J,K)/A(K,K))                              JAC00177
      EPSB=(B(J,K)/B(J,J))*(B(J,K)/B(K,K))                              JAC00178
      IF (EPSA.LT.EPS .AND. EPSB.LT.EPS) GO TO 250                      JAC00179
      GO TO 280                                                         JAC00180
  250 CONTINUE                                                          JAC00181
C                                                                       JAC00182
C     FILL OUT BOTTOM TRIANGLE OF RESULTANT MATRICES, SCALE EIGENVECTORSJAC00183
C                                                                       JAC00184
  255 DO 260 I=1,N                                                      JAC00185
      DO 260 J=I,N                                                      JAC00186
      A(J,I)=A(I,J)                                                     JAC00187
  260 B(J,I)=B(I,J)                                                     JAC00188
      DO 270 J=1,N                                                      JAC00189
      BB=SQRT(B(J,J))                                                   JAC00190
      DO 270 K=1,N                                                      JAC00191
  270 X(K,J)=X(K,J)/BB                                                  JAC00192
      GO TO 900                                                         JAC00193
C                                                                       JAC00194
C     UPDATE  D  MATRIX AND START NEW SWEEP, IF ALLOWED                 JAC00195
C                                                                       JAC00196
  280 DO 290 I=1,N                                                      JAC00197
  290 D(I)=EIGV(I)                                                      JAC00198
      IF (NSWEEP.LT.NSMAX) GO TO 40                                     JAC00199
      GO TO 255                                                         JAC00200
C                                                                       JAC00201
  800 STOP                                                              JAC00202
  900 RETURN                                                            JAC00203
C                                                                       JAC00204
 2000 FORMAT (//,' SWEEP NUMBER IN *JACOBI* = ',I8)                     JAC00205
 2010 FORMAT (' ',6E20.12)                                              JAC00206
 2020 FORMAT (//,' *** ERROR *** SOLUTION STOP',/,                      JAC00207
     1        ' MATRICES NOT POSITIVE DEFINITE')                        JAC00208
 2030 FORMAT (//,' CURRENT EIGENVALUES IN *JACOBI* ARE',/)              JAC00209
      END                                                               JAC00210


PROGRAM MAIN
USE TOPT_MOD
IMPLICIT NONE

!Seasonal Amplitude of temperature: (Tmax - Tmin)/2
INTEGER, PARAMETER :: NAm     = 2
REAL,    PARAMETER :: Am(NAm) = [3.D0, 6.D0]

integer,   PARAMETER :: N_EKn = 2     !Number of activation energy values for KN
REAL,    PARAMETER :: E_Kn(N_EKn)= [0.d0, 0.18d0]  !E values for KN, Q10 = 1.3 = 1.8/1.4

INTEGER, PARAMETER :: NaG        = 2
REAL,        PARAMETER :: alphaG(NaG)= [1.1d0, 1.9d0]  !Kill-the-winner coefficient

!A vector of mean temperature (three)
integer, parameter :: NavgT = 2
REAL, parameter :: avgtemp(NavgT)   = [6.D0,  24.D0]

REAL    :: cur_day ! Current simulation time (day)
INTEGER :: j,k, NI,v, u
REAL    :: t1, t2, Ew
character(len=10), parameter :: format_string = "(A3,I0)"

!Filename
character(LEN=20) :: fname = 'Mod.out'

!Start
CALL CPU_TIME(T1)

! Number of integrations:
NI  = NDAYS*INT(1.d0/dtdays)

!Initialise phytoplankton label
DO i = 1, NPHY
   WRITE(PHYLAB(I), FORMAT_STRING) 'PHY',I
   WRITE(muMLAB(I), FORMAT_STRING) 'muM',I
ENDDO

DO v = 1, NAm
   DO i = 1, NavgT
     do k = 1, NaG
      do u = 1, N_EKn
            !Initialise variables:
            NO3  = 1.; PHY(:)=1D-3;
            PHYt = sum(PHY(:))
            ZOO  = PHYt*0.1

            !Create file name:
            WRITE(fname, 100) 'Mod', int(avgtemp(i)),'_',k,'_',v, '_', u, '.out'

100 format(A3, I0,3(A1,I0),A4)

            !Create file for saving results
            OPEN (UNIT=10, file = fname, status = 'replace')
            WRITE(10, 101) 'Day', 'Temp', 'NO3', 'PHY', 'ZOO', 'avgZ', &
                           'sigmaZ', 'mumax', PHYLAB, muMLAB, "Ew"

            !Calculate temperature
            cur_day   = 0.d0
            temp      = avgtemp(i) - Am(v)*cosine(cur_day)
            mumax_avg = 0.d0
            mumax(:)  = 0.d0

            call moments !Calculate trait variance

            !Record initial conditions:
            WRITE(10, 102) 0., temp, NO3, PHYt, ZOO, avgZ, sigmaZ, 0., PHY, mumax, 0.65

            DO j = 1, NI !NI: number of integrations

              !Current time (in days)
              cur_day = dtdays*dble(j)
              temp    = avgtemp(i) - Am(v)*cosine(cur_day)

              !Save data per day:
              IF (mod(j,int(1.d0/dtdays)) .eq. 0) THEN
                call moments
                call SENSITIVITY(E_Kn(u), Ew)
                WRITE(10, 102) cur_day, temp, NO3, PHYt, ZOO, avgZ, sigmaZ,mumax_avg, PHY,mumax, Ew
              ENDIF

              call biology(alphaG(k), E_Kn(u))
            ENDDO

            !Close file
            CLOSE(10)
           enddo
          Enddo
   ENDDO
ENDDO

CALL CPU_TIME(T2)
WRITE(6, '("TIME = ",F8.3," MINS.")') (T2-T1)/60.0

101 format(6x,440(A7, 6x))
102 format(F12.1, 1x, 439(1pe10.2, 1x))
END PROGRAM


module mo_test_loop

  use mo_kind, only: i4, i8, sp, dp

  implicit none

  public :: n_save_state
  public :: loop

  interface loop
     module procedure loops, loopd
  end interface loop

  private

  integer(i4), parameter :: n_save_state = 132_i4

CONTAINS

  subroutine loops(seed, SingleIntegerRN, save_state)

    implicit none

    integer(i4),                                    intent(in)    :: seed
    integer(i4),                                    intent(out)   :: SingleIntegerRN
    integer(i4), optional, dimension(n_save_state), intent(inout) :: save_state

    integer(i4)        :: wlen, r, s, a, b, c, d

    integer(i4), save  :: w
    integer(i4), save  :: x(0:127)                 ! x(0) ... x(r-1)
    integer(i4)        :: weyl = 1640531527_i4     !Z'61C88647'       ! Hexadecimal notation
    ! integer(i4)        :: weyl = 1_i4     !Z'61C88647'       ! Hexadecimal notation
    integer(i4)        :: t, v
    integer(i4), save  :: i = -1                   ! i<0 indicates first call
    integer(i4)        :: k

    !$omp   threadprivate(x,i,w)

    wlen = 32
    r = 128
    s = 95
    a = 17
    b = 12
    c = 13
    d = 15

    if ( present(save_state) .and. (seed .eq. 0) ) then
       x(0:r-1) = save_state(1:r)
       i        = save_state(r+1)
       w        = save_state(r+2)
    end if

    If ((i .lt. 0) .or. (seed .ne. 0)) then     ! Initialization necessary
       If (seed .ne. 0) then                   ! v must be nonzero
          v = seed
       else
          v = NOT(seed)
       end if

       do k=wlen, 1, -1                          ! Avoid correlations for close seeds
          ! This recurrence has period of 2^32-1
          v = IEOR(v, ISHFT(v,  13))
          v = IEOR(v, ISHFT(v, -17))
          v = IEOR(v, ISHFT(v,   5))
       end do

       ! Initialize circular array
       w = v
       do k=0,r-1
          w = w + weyl
          v = IEOR(v,ISHFT(v,13))
          v = IEOR(v,ISHFT(v,-17))
          v = IEOR(v,ISHFT(v, 5))
          x(k) = v + w
       end do

       ! Discard first 4*r results (Gimeno)
       i = r-1
       do k = 4*r,1,-1
          i = IAND(i+1,r-1)
          t = x(i)
          v = x(IAND(i+(r-s),r-1))
          t = IEOR(t,ISHFT(t,a))
          t = IEOR(t,ISHFT(t,-b))
          v = IEOR(v,ISHFT(v,c))
          v = IEOR(v,IEOR(t,ISHFT(v,-d)))
          x(i) = v
       end do
    end if ! end of initialization

    ! Apart from initialization (above), this is the generator
    i = IAND(i+1,r-1)
    t = x(i)
    v = x(IAND(i+(r-s),r-1))
    t = IEOR(t,ISHFT(t,a))
    t = IEOR(t,ISHFT(t,-b))
    v = IEOR(v,ISHFT(v,c))
    v = IEOR(v,IEOR(t,ISHFT(v,-d)))
    x(i) = v

    w = w + weyl

    SingleIntegerRN = v+w

    if( present(save_state) ) then
       save_state(1:r)   = x(0:r-1)
       save_state(r+1)   = i
       save_state(r+2)   = w
       if ((r+3) <= n_save_state) save_state(r+3:n_save_state) = 0
    end if

  end subroutine loops

  subroutine loopd(seed,DoubleRealRN,save_state)

    implicit none

    integer(i8),                                    intent(in)    :: seed
    real(DP),                                       intent(out)   :: DoubleRealRN
    integer(i8), optional, dimension(n_save_state), intent(inout) :: save_state

    integer(i8)        :: wlen, r, s, a, b, c, d

    integer(i8), save  :: w
    integer(i8), save  :: x(0:63)                  ! x(0) ... x(r-1)
    integer(i8)        :: weyl = 7046029254386353131_i8
    integer(i8)        :: t,v, tmp
    integer(i8), save  :: i = -1                   ! i<0 indicates first call
    integer(i8)        :: k

    real(DP)            :: t53 = 1.0_DP/9007199254740992.0_DP                     ! = 0.5^53 = 1/2^53

    !$omp   threadprivate(x,i,w)

    ! produces a 53bit Integer Random Number (0...9 007 199 254 740 992) and
    ! scales it afterwards to (0.0,1.0)

    wlen = 64_i8
    r = 64_i8
    s = 53_i8
    a = 33_i8
    b = 26_i8
    c = 27_i8
    d = 29_i8

    if ( present(save_state) .and. (seed .eq. 0_i8) ) then
       x(0:r-1)  = save_state(1:r)
       i         = save_state(r+1)
       w         = save_state(r+2)
    end if

    If ((i .lt. 0) .or. (seed .ne. 0)) then     ! Initialization necessary
       If (seed .ne. 0) then                   ! v must be nonzero
          v = seed
       else
          v = NOT(seed)
       end if

       do k=wlen,1,-1                          ! Avoid correlations for close seeds
          ! This recurrence has period of 2^64-1
          v = IEOR(v,ISHFT(v,7))
          v = IEOR(v,ISHFT(v,-9))
       end do

       ! Initialize circular array
       w = v
       do k=0,r-1
          ! w = w + weyl
          if (w < 0_i8) then
             w = w + weyl
          else if ((huge(w) - w) > weyl) then
             w = w + weyl
          else
             tmp = -(huge(w) - w - weyl)
             w =  tmp - huge(w) - 2_i8
          endif
          v = IEOR(v,ISHFT(v,7))
          v = IEOR(v,ISHFT(v,-9))
          x(k) = v + w
       end do

       ! Discard first 4*r results (Gimeno)
       i = r-1
       do k = 4*r,1,-1
          i = IAND(i+1, r-1)
          t = x(i)
          v = x(IAND(i+(r-s),r-1))
          t = IEOR(t,ISHFT(t,a))
          t = IEOR(t,ISHFT(t,-b))
          v = IEOR(v,ISHFT(v,c))
          v = IEOR(v,IEOR(t,ISHFT(v,-d)))
          x(i) = v
       end do
    end if ! end of initialization

    ! Apart from initialization (above), this is the generator
    v = 0_i8
    Do While (v .eq. 0_i8)
       i = IAND(i+1,r-1)
       t = x(i)
       v = x(IAND(i+(r-s),r-1))
       t = IEOR(t,ISHFT(t,a))
       t = IEOR(t,ISHFT(t,-b))
       v = IEOR(v,ISHFT(v,c))
       v = IEOR(v,IEOR(t,ISHFT(v,-d)))
       x(i) = v
       w = w + weyl
       v = v + w
       v = ISHFT(v,-11)
    End Do

    DoubleRealRN = t53*v

    if( present(save_state) ) then
       save_state(1:r)   = x(0:r-1)
       save_state(r+1)   = i
       save_state(r+2)   = w
       if ((r+3) <= n_save_state) save_state(r+3:n_save_state) = 0
    end if

  end subroutine loopd

end module mo_test_loop


      PROGRAM xf1dim
C     driver for routine f1dim
      INTEGER NDIM,NMAX
      PARAMETER(NDIM=3,NMAX=50)
      INTEGER i,j,ncom
      REAL pcom,xicom
      COMMON /f1com/ pcom(NMAX),xicom(NMAX),ncom
      REAL p(NDIM),xi(NDIM)
      EXTERNAL f1dim
      DATA p/0.0,0.0,0.0/
      ncom=NDIM
      write(*,'(/1x,a)') 'Enter vector direction along which to'
      write(*,'(1x,a)') 'plot the function. Minimum is in the'
      write(*,'(1x,a)') 'direction 1.0,1.0,1.0 - Enter X,Y,Z:'
      read(*,*) (xi(i),i=1,3)
      do 11 j=1,NDIM
        pcom(j)=p(j)
        xicom(j)=xi(j)
11    continue
      call scrsho(f1dim)
      END
      REAL FUNCTION func(x)
      INTEGER i
      REAL x(3)
      func=0.0
      do 11 i=1,3
        func=func+(x(i)-1.0)**2
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xf1dim.for


      subroutine basis1 (r,s,h,p)
c     implicit double precision (a-h,o-z)                                    dp
c
      dimension h(*),p(2,*)
c
      rp=1.0+r
      sp=1.0+s
      rm=1.0-r
      sm=1.0-s
      h(1)=0.25*rp*sp
      h(2)=0.25*rm*sp
      h(3)=0.25*rm*sm
      h(4)=0.25*rp*sm
      p(1,1)=0.25*sp
      p(1,2)=-p(1,1)
      p(1,3)=-0.25*sm
      p(1,4)=-p(1,3)
      p(2,1)=0.25*rp
      p(2,2)=0.25*rm
      p(2,3)=-p(2,2)
      p(2,4)=-p(2,1)
      return
      end


      SUBROUTINE iau_TPORS ( XI, ETA, A, B, A01, B01, A02, B02, N )
*
*  - - - - - - - - - -
*   i a u _ T P O R S
*  - - - - - - - - - -
*
*  In the tangent plane projection, given the rectangular coordinates
*  of a star and its spherical coordinates, determine the spherical
*  coordinates of the tangent point.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Given:
*     XI,ETA    d       rectangular coordinates of star image (Note 2)
*     A,B       d       star's spherical coordinates (Note 3)
*
*  Returned:
*     A01,B01   d       tangent point's spherical coordinates, Soln. 1
*     A02,B02   d       tangent point's spherical coordinates, Soln. 2
*     N         i       number of solutions:
*                         0 = no solutions returned (Note 5)
*                         1 = only the first solution is useful (Note 6)
*                         2 = both solutions are useful (Note 6)
*
*  Notes:
*
*  1) The tangent plane projection is also called the "gnomonic
*     projection" and the "central projection".
*
*  2) The eta axis points due north in the adopted coordinate system.
*     If the spherical coordinates are observed (RA,Dec), the tangent
*     plane coordinates (xi,eta) are conventionally called the "standard
*     coordinates".  If the spherical coordinates are with respect to a
*     right-handed triad, (xi,eta) are also right-handed.  The units of
*     (xi,eta) are, effectively, radians at the tangent point.
*
*  3) All angular arguments are in radians.
*
*  4) The angles A01 and A02 are returned in the range 0-2pi.  The
*     angles B01 and B02 are returned in the range +/-pi, but in the
*     usual, non-pole-crossing, case, the range is +/-pi/2.
*
*  5) Cases where there is no solution can arise only near the poles.
*     For example, it is clearly impossible for a star at the pole
*     itself to have a non-zero xi value, and hence it is meaningless
*     to ask where the tangent point would have to be to bring about
*     this combination of xi and dec.
*
*  6) Also near the poles, cases can arise where there are two useful
*     solutions.  The returned value N indicates whether the second of
*     the two solutions returned is useful;  N=1 indicates only one
*     useful solution, the usual case.
*
*  7) The basis of the algorithm is to solve the spherical triangle PSC,
*     where P is the north celestial pole, S is the star and C is the
*     tangent point.  The spherical coordinates of the tangent point are
*     [a0,b0];  writing rho^2 = (xi^2+eta^2) and r^2 = (1+rho^2), side c
*     is then (pi/2-b), side p is sqrt(xi^2+eta^2) and side s (to be
*     found) is (pi/2-b0).  Angle C is given by sin(C) = xi/rho and
*     cos(C) = eta/rho.  Angle P (to be found) is the longitude
*     difference between star and tangent point (a-a0).
*
*  8) This routine is a member of the following set:
*
*         spherical       vector       solve for
*
*         iau_TPXES      iau_TPXEV      xi,eta
*         iau_TPSTS      iau_TPSTV       star
*       > iau_TPORS <    iau_TPORV      origin
*
*  Called:
*     iau_ANP      normalize angle into range 0 to 2pi
*
*  References:
*
*     Calabretta M.R. & Greisen, E.W., 2002, "Representations of
*     celestial coordinates in FITS", Astron.Astrophys. 395, 1077
*
*     Green, R.M., "Spherical Astronomy", Cambridge University Press,
*     1987, Chapter 13.
*
*  This revision:   2018 January 2
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION XI, ETA, A, B, A01, B01, A02, B02
      INTEGER N

      DOUBLE PRECISION XI2, R, SB, CB, RSB, RCB, W2, W, S, C

      DOUBLE PRECISION iau_ANP

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      XI2 = XI*XI
      R = SQRT(1D0+XI2+ETA*ETA)
      SB = SIN(B)
      CB = COS(B)
      RSB = R*SB
      RCB = R*CB
      W2 = RCB*RCB - XI2
      IF ( W2 .GE. 0D0 ) THEN
         W = SQRT(W2)
         S = RSB - ETA*W
         C = RSB*ETA + W
         IF ( XI .EQ. 0D0 .AND. W .EQ. 0D0 ) W = 1D0
         A01 = iau_ANP(A - ATAN2(XI,W))
         B01 = ATAN2(S,C)
         W = -W
         S = RSB - ETA*W
         C = RSB*ETA + W
         A02 = iau_ANP(A - ATAN2(XI,W))
         B02 = ATAN2(S,C)
         IF ( ABS(RSB) .LT. 1D0 ) THEN
            N = 1
         ELSE
            N = 2
         END IF
      ELSE
         N = 0
      END IF

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2020
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


SUBROUTINE Solve

   ! -------------------------------------------------------------------------
   ! NAME:   Solve
   ! PARENT: Feritas
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Solve the system of algebraic equations and rearrange the obtained
   !         solutions to appropriate arrays to store the unknows.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   USE PrecTypes
   USE GlobalData

   IMPLICIT NONE

   INTEGER(i4b) :: i,j,k,l
   INTEGER(i4b) :: returnCode
   INTEGER(i4b), ALLOCATABLE :: iwk(:)
   REAL(dp), ALLOCATABLE ::  wk(:)
   REAL(dp), PARAMETER :: epsilon = 1.0e-14_dp

   ALLOCATE( wk(N_unknowns) )
   ALLOCATE( iwk(N_unknowns) )

   ! Solve the system [K]{u} = {F} by LU-decomposition method
   CALL LUfact(Km, N_unknowns, N_unknowns, Fv, epsilon, wk, iwk, returnCode)

   WRITE(*,'(A,I2)') '  Return from LU factorization: returnCode =',returnCode

   DEALLOCATE( wk )
   DEALLOCATE( iwk )

   SELECT CASE(pcode)

   ! Steady-state heat conduction problem
   CASE(1)
      ! ------------------------------------
      ! Copy the obtained temperature into the nodal temperature vector
      DO i=1,node
         IF(ptable(i) > 0) then
            T(i) = Fv(ptable(i))
         END IF
      END DO

      ! ------------------------------------
      ! Computation of unknown nodal heat fluxes
      DO i=1,node
         IF(ptable(i) < 0) then
            DO k=1,node
               Q(i) = Q(i) + Kmm(-ptable(i), k) * T(k)
            END DO
         END IF
      END DO

	! Output for debugging
	! write(*,'(a)') 'Nodal temperature'
	! do i=1,node
	!    write(*,'(I3,2x,3(E15.8,2x))')   i,T(i)
	! end do
	! write(*,'(a)') 'Boundary equivalent nodal heat flow'
	! do i=1,node
	!    if(bNodeFlag(i) == 1) then
	!       write(*,'("Q(",I3,")=",E15.8)') i,Q(i)
	!    end if
	! end do

   ! Linear elastostatic and thermo-elastostatic cases
   CASE(2,3)
      ! ------------------------------------
      ! Copy the obtained displacements into the nodal displacement vector
      DO i=1,node
         DO j=1,dir
            IF(table(i,j) > 0) then
               u(i,j) = Fv(table(i,j))
            END IF
         END DO
      END DO

      ! ------------------------------------
      ! Computation of unknown nodal reaction forces
      DO i=1,node
         DO j=1,dir
            IF(table(i,j) < 0) then
               DO k=1,node
                  DO l=1,dir
                     F(i,j) = F(i,j) + Kmm(-table(i,j), 2*k-2+l)*u(k,l)
                  END DO
               END DO
            END IF
            IF(table(i,j) < 0) F(i,j) = F(i,j) - Fvv(-table(i,j))
         END DO
      END DO

   ! Output for debugging
   !write(*,'(a)') 'Nodal displacements'
   !do i=1,node
   !   write(*,'(I3,2x,3(E15.8,2x))')   i,(u(i,j),j=1,dir)
   !end do
   !write(*,'(a)') 'Boundary equivalent nodal forces'
   !do i=1,node
   !   if(bNodeFlag(i) == 1) then
   !      do j=1,dir
   !         write(*,'("F(",I3,",",I3,")=",E15.8)') i,j,F(i,j)
   !      end do
   !   end if
   !end do

      ! ------------------------------------
      ! Computation of stresses and strains
      CALL StressStrain

   END SELECT

   RETURN

END SUBROUTINE Solve


!>
!! @copyright Copyright (c) 2013-2016, Université Pierre et Marie Curie
!! All rights reserved.
!!
!! <b>hiCL</b> is owned by Université Pierre et Marie Curie (UPMC),
!! funded by TOTAL, and written by Issam SAID <said.issam@gmail.com>.
!!
!! Redistribution and use in source and binary forms, with or without
!! modification, are permetted provided that the following conditions
!! are met:
!!
!! 1. Redistributions of source code must retain the above copyright
!!    notice, this list of conditions and the following disclaimer.
!! 2. Redistributions in binary form must reproduce the above copyright
!!    notice, this list of conditions and the following disclaimer inthe
!!    documentation and/or other materials provided with the distribution.
!! 3. Neither the name of the UPMC nor the names of its contributors
!!    may be used to endorse or promote products derived from this software
!!    without specific prior written permission.
!!
!! THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
!! INCLUDING, BUT NOT LIMITED TO, WARRANTIES OF MERCHANTABILITY AND FITNESS
!! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UPMC OR
!! ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
!! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
!! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
!! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
!! LIABILITY, WETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
!! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!!
!! @file sgemm/main.f90
!! @author Issam SAID
!! @brief An example of a 3D finite difference stencil code based on
!! the hiCL Fortran interface.
!!
!<
program stencil_3d_fortran
	use m_hicl

    integer(kind=8),    parameter :: N = 320
    integer(kind=4)               :: n4

    real,             allocatable :: u(:,:,:)
    real,             allocatable :: v(:,:,:)
    real,             allocatable :: coeffs(:)

    integer(kind=8), dimension(3) :: global = (/N, N, 1_8/)
    integer(kind=8), dimension(3) :: local  = (/16_8, 16_8, 1_8/)

    type(hidev_t),        pointer :: device

	write(*,*) "... start of the hiCL 3D stencil Fortran example"

    !!
    !!< Initialize hiCL with selecting the default GPU.
    !!
    call hicl_init(GPU)

    !!
    !!< Load and build the OpenCL kernel that runs the multiplication.
    !!< Note the '-cl-kernel-arg-info' that is added for NVIDIA GPUs to
    !!< use some OpenCL 1.2 features.
    !!
    call hicl_load(PREFIX//"/stencil_3d.cl", "-cl-kernel-arg-info");

	!!
    !!< Get a pointer to the desired device (in this case the default GPU).
    !!
    call hicl_dev_find(DEFAULT, device)

    allocate(u(N+8, N+8, N+8))
    allocate(v(N+8, N+8, N+8))
    allocate(coeffs(5))
    u  = 0
    v  = 2.1
    n4 = N

    coeffs(1) = -2.6;
    coeffs(2) =  1.6;
    coeffs(3) = -0.2;
    coeffs(4) =  0.02;
    coeffs(5) = -0.001;

    !!
    !!< Wrap the buffers into hiCL memory objects.
    !!
    call hicl_mem_wrap(u, device, ior(HWA, READ_WRITE))
    call hicl_mem_wrap(v, device, ior(HWA, READ_WRITE))
    call hicl_mem_wrap(coeffs, device, ior(HWA, READ_ONLY))

    !!
    !!< Set the work size and the dimensions of the kernel.
    !!
    call hicl_knl_set_wrk("stencil_3d", 2, global, local)

    !!
    !!< Set the arguments of the kernel.
    !!< Unfortunately variadic functions cannot be used in Fortran, each
    !!< argument has to be set apart.
    !!
    call hicl_knl_set("stencil_3d", 0, v)
    call hicl_knl_set("stencil_3d", 1, u)
    call hicl_knl_set("stencil_3d", 2, coeffs)
    call hicl_knl_set("stencil_3d", 3, n4)
    call hicl_knl_set("stencil_3d", 4, n4)
    call hicl_knl_set("stencil_3d", 5, n4)

    !!
    !!< Run the kernel on the default GPU.
    !!
    call hicl_knl_exec("stencil_3d", device);

    !!
    !!< Update the u buffer on the CPU side so that the results can be seen
    !!< on the host side.
    !!
    call hicl_mem_update(u, READ_ONLY)

    deallocate(u, v, coeffs)

    !!
    !!< Release hiCL resources.
    !!
    call hicl_release()
    write(*,*) "... end   of the hiCL 3D stencil Fortran example"
end program stencil_3d_fortran


      SUBROUTINE TEST7(N,A,B)
      INTEGER N
      REAL A(N,N),B(N,N)

      DO 10 L = 1, N
         DO 20 J = L+1, N
            A(L,J) = A(L,J)/A(L,L)
 20      CONTINUE
         DO 30 I = L+1, N
            DO 40 K = L+1, N
               B(I,K) = A(I,L) * A(L,K)
               A(I,K) = A(I,K) - B(I,K)
 40         CONTINUE
 30      CONTINUE
 10   CONTINUE
      END