  subroutine PreCalc_CG()
  USE VAPHFB_Par
  implicit none
  REAL(DP) :: CG

! ......................................
! J1,J2 are j1+1/2, j2+1/2, respectively
! M1,M2 are m1+1/2, m2+1/2, starting from -J1+1 to J1
! J12,M12 are the real values.
! .....................................
  integer j1,j2,m1,m2,J12min,J12max,J12,M12
  integer J1max,J1max2

  write(*,*) ' Preparing CG coefficients ....'
  J1max=12
  J1max2=J1max*2-1

   if(HO%jmaxp5.gt.J1max) then
      J1max =HO%jmaxp5
      J1max2=HO%jmaxp5*2-1
   endif

   if(.NOT. ALLOCATED(CG_Save)) &
 & ALLOCATE(CG_Save(1:J1max,-J1max:J1max,1:J1max,-J1max:J1max, &
 &                  0:J1max2,-J1max2:J1max2))

      write(*,'(a,f6.3,a)')'Main: allocated CG_Save with memory:', &
     & sizeof(CG_Save)/(1024*1024*1024.0),'G byte ..'

   CG_Save(1:J1max,-J1max:J1max,1:J1max,-J1max:J1max,0:J1max2,-J1max2:J1max2) = zero
  do J1=1,J1max !HO%jmaxp5
  do J2=1,J1max !HO%jmaxp5
  do M1=-J1+1,J1
  do M2=-J2+1,J2
    J12min = abs(J1-J2)
    J12max = abs(J1+J2-1)
    M12    = M1+M2-1
  do J12=J12min,J12max
     CG_Save(J1,M1,J2,M2,J12,M12) = CG(J1*2-1,M1*2-1,J2*2-1,M2*2-1,2*J12,2*M12)
  enddo
  enddo
  enddo
  enddo
  enddo
  end

  FUNCTION CG(j1, m1, j2, m2, J, M)
! ....................................
! all the quantum numbers are douibled
!
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  INTERFACE

  FUNCTION FacLOG(N)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
  INTEGER, INTENT(IN) :: N
  REAL(DP) ::  FacLOG
  END FUNCTION FacLOG
  END INTERFACE

  INTEGER, INTENT(IN) :: j1, j2, m1, m2, J, M
  REAL(DP) :: CG

  INTEGER :: H_Min, H_Max, H
  REAL(DP) :: CG_1, CG_2

  REAL(DP) :: fact1, fact2, fact3, fact4, fact5, fact6, fact7, fact8
  REAL(DP) :: fact9, fact10

  REAL(DP) :: fact11

  IF (  &
       & (m1 + m2   .NE. M )        .OR. &
       & (ABS(m1)   .GT. j1)        .OR. &
       & (ABS(m2)   .GT. j2)        .OR. &
       & (ABS(M)    .GT. J )        .OR. &
       & (MOD(j1+m1,2) .NE. 0) .OR. &
       & (MOD(j2+m2,2) .NE. 0) .OR. &
       & (MOD(J + M,2 ).NE. 0) .OR. &
       & (j1 + J  - j2 .LT. 0)       .OR. &
       & (J  - j1 + j2 .LT. 0)       .OR. &
       & (j1 + j2 - J  .LT. 0)       .OR. &
       & (j1 .LT. 0) .OR. (j2 .LT. 0) .OR. (J .LT. 0))THEN
     CG = 0
     RETURN
  END IF

  H_Max = MIN(J-j1+j2, J+m1+m2, J+j2+m1) / 2
  H_Min = MAX(0, m1-j1, -j1+j2+m1+m2) / 2

  IF (H_Min .GT. H_Max) STOP "Factorial: Hmin Hmax error"

  fact1 = FacLOG((j1 + J - j2) / 2)
  fact2 = FacLOG((J - j1 + j2) / 2)
  fact3 = FacLOG((j1 + j2 - J) / 2)
  fact4 = FacLOG((J + m1 + m2) / 2)
  fact5 = FacLOG((J - m1 - m2) / 2)
  fact6 = FacLOG((J + j1 + j2) / 2 + 1)
  fact7 = FacLOG((j1 - m1)     / 2)
  fact8 = FacLOG((j1 + m1)     / 2)
  fact9 = FacLOG((j2 - m2)     / 2)
  fact10= FacLOG((j2 + m2)     / 2)

 !  IF (   fact1 .LE. 0.0 .OR. &
 !      & fact2 .LE. 0.0 .OR. &
 !      & fact3 .LE. 0.0 .OR. &
 !      & fact4 .LE. 0.0 .OR. &
 !      & fact5 .LE. 0.0 .OR. &
 !      & fact6 .LE. 0.0 .OR. &
 !      & fact7 .LE. 0.0 .OR. &
 !      & fact8 .LE. 0.0 .OR. &
 !      & fact9 .LE. 0.0 .OR. &
 !      & fact10 .LE. 0.0 ) THEN
 !    WRITE(0,*) j1, j2, J, m1, m2
 !    WRITE(0,*) fact1, fact2, fact3, fact4, fact5
 !    WRITE(0,*) fact6, fact7, fact8, fact9, fact10
 !    STOP
  !END IF

 CG_1 = fact1 + fact2 + fact3 + fact4 + fact5 &
       & - &
       &(fact6 + fact7 + fact8 + fact9 + fact10)

 CG_2 = 0.0D0

  DO H = H_Min, H_Max

     fact1 = FacLOG((J + j2 + m1) / 2 - H)
     fact2 = FacLOG((j1 - m1) / 2 + H)
     fact3 = FacLOG((J - j1 + j2) / 2 - H)
     fact4 = FacLOG((J + m1 + m2) / 2 - H)
     fact5 = FacLOG(H)
     fact6 = FacLOG((j1 - j2 - m1 - m2) / 2 + H)

     fact11 = fact1 + fact2 - (fact3 + fact4 + fact5 + fact6)

     CG_2 = CG_2 + &
          & (-1)**(MOD(H+(j2+m2)/2,2)) * SQRT(DBLE(J+1)) * EXP(fact11)

  END DO

  CG = exp(0.50D0 * CG_1) * CG_2

END FUNCTION CG

  FUNCTION Wigner_3j (j1, j2, J, m1, m2, M)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  ! Wigner 3j-Symbol

  ! j1/2 j2/2 J/2 !
  ! m1/2 m2/2 M/2 !

  INTERFACE
     FUNCTION CG(j1, m1, j2, m2, J, M)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: j1, j2, m1, m2, J, M
       REAL(DP) :: CG
     END FUNCTION CG
  END INTERFACE

  INTEGER, INTENT(IN) :: j1, j2, J, m1, m2, M

  REAL (DP) :: Wigner_3j

  Wigner_3j = (-1)**((j1-j2-M)/2) / SQRT(DBLE(J)+1.0D0) * CG(j1,m1,j2,m2,J,-M)

  RETURN

END FUNCTION Wigner_3j

FUNCTION FacLOG(N)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  ! return LOG(N!), not N!

  INTEGER, INTENT(IN) :: N

  REAL(DP) ::  FacLOG

  INTEGER :: i

  FacLOG = 1.0D0

  IF ( N .EQ. 0) THEN
     FacLOG = 0.0D0
     RETURN
  END IF

  IF ( N .LT. 0) THEN
     PRINT *, N
     STOP "FacLOG: Impossible to calculate N! N is negative"
  END IF

  DO i = 1, N
     FacLOG = FacLOG * DBLE(i)
  END DO

  FacLOG = LOG(FacLOG)

  RETURN

END FUNCTION FacLOG

FUNCTION DBLEFacLOG(N)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
  ! returns LOG(N!!), not N!!
  INTEGER, INTENT(IN) :: N
  REAL(DP) ::  DBLEFacLOG

  INTEGER :: i

  DBLEFacLOG = 1.0D0

  IF ( N .EQ. 0) THEN
     DBLEFacLOG = 0.0D0
     RETURN
  END IF

  IF ( N .LT. 0) THEN
     PRINT *, N
     STOP "FacLOG: Impossible to calculate N! N is negative"
  END IF

  IF (MOD(N, 2) .EQ. 0 ) THEN ! N = even
     DO i = 2, N, 2
        DBLEFacLOG = DBLEFacLOG * DBLE(i)
     END DO
  ELSE ! N = odd
     DO i = 1, N, 2
        DBLEFacLOG = DBLEFacLOG * DBLE(i)
     END DO
  END IF

  DBLEFacLOG = LOG(DBLEFacLOG)

  RETURN

END FUNCTION DBLEFacLOG

FUNCTION Triangle(a,b,c)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  ! \Delta(a/2, b/2, c/2)
  ! \Delta(a/2, b/2, c/2) = sqrt( (a/2+b/2-c/2)! (a/2-b/2+c/2)! (-a/2+b/2+c/2)! / (a/2+b/2+c/2+1)! )
  ! if a/2,b/2,c/2 do not satisfy the triangle inequality, it returns zero.

  INTERFACE
     FUNCTION FacLOG(N)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
     INTEGER, INTENT(IN) :: N
     REAL(DP) ::  FacLOG
     END FUNCTION FacLOG
  END INTERFACE

  INTEGER, INTENT(IN) :: a,b,c

  REAL(DP) :: Triangle, temp

  REAL(DP) :: F1, F2, F3, F4

  Triangle = 0.0D0
  IF (a+b-c .LT. 0 .OR. a-b+c .LT. 0 .OR. -a+b+c .LT. 0 .OR. a+b+c+1 .LT. 0) RETURN

  IF( MOD( a+b-c,2) .NE. 0) RETURN
  IF( MOD( a-b+c,2) .NE. 0) RETURN
  IF( MOD(-a+b+c,2) .NE. 0) RETURN
  IF( MOD( a+b+c,2) .NE. 0) RETURN

  F1 = FacLOG(( a + b - c    )/2)
  F2 = FacLOG(( a - b + c    )/2)
  F3 = FacLOG((-a + b + c    )/2)
  F4 = FacLOG(( a + b + c)/2 + 1)

  temp = F1 + F2 + F3 - F4
  Triangle = EXP(0.50D0 * temp)

!  Triangle = F1 * F2 * F3 / F4

  RETURN

END FUNCTION Triangle

!  .....................................................
   FUNCTION Wigner_6j(a,b,c,d,e,f)
!  .....................................................
!  a,b,c,d,e,f are doubled
!   ( a  b  c )
!   ( d  e  f )
!  .....................................................
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  ! Wigner 6j Symbol

  ! a b c !
  ! d e f !

  INTERFACE

     FUNCTION FacLOG(N)
      IMPLICIT NONE
      INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: N
       REAL(DP) ::  FacLOG
     END FUNCTION FacLOG

     FUNCTION Triangle(a,b,c)
       IMPLICIT NONE
       INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: a,b,c
       REAL(DP) :: Triangle
     END FUNCTION Triangle

  END INTERFACE

 INTEGER, INTENT(IN) :: a,b,c,d,e,f

  REAL(DP) :: Wigner_6j

  REAL(DP),DIMENSION(1:4) :: Delta
  REAL(DP),DIMENSION(1:7) :: Fact
  REAL(DP) :: W6J1, W6J2, temp

  INTEGER :: t, t_min, t_max

  Wigner_6j = 0.0D0

  IF ( a < 0) RETURN
  IF ( b < 0) RETURN
  IF ( c < 0) RETURN
  IF ( d < 0) RETURN
  IF ( e < 0) RETURN
  IF ( f < 0) RETURN
  IF ( a < ABS(b-c) .OR. a > b+c ) RETURN
  IF ( a < ABS(e-f) .OR. a > e+f ) RETURN
  IF ( d < ABS(b-f) .OR. d > b+f ) RETURN
  IF ( d < ABS(e-c) .OR. d > e+c ) RETURN

  Delta(1) = DBLE(Triangle(a,b,c))
  Delta(2) = DBLE(Triangle(a,e,f))
  Delta(3) = DBLE(Triangle(d,b,f))
  Delta(4) = DBLE(Triangle(d,e,c))

  W6J1 = Delta(1)*Delta(2)*Delta(3)*Delta(4)

!  IF ( ABS(W6J1) .LT. 1.0D-10) THEN
!     Wigner_6j = 0.0D0
!     RETURN
!  END IF

  t_max = MIN((a+b+d+e)/2, (b+c+e+f)/2, (c+a+f+d)/2)

  t_min = MAX((a+b+c)/2, (a+e+f)/2, (d+b+f)/2, (d+e+c)/2)

!  IF ( t_min .GT. t_max) THEN
!     Wigner_6j = 0.0D0
!     RETURN
!  END IF

  W6J2 = 0.0D0

  DO t = t_min, t_max

     fact(1) = FacLOG( t + (- a - b - c)/2 )
     fact(2) = FacLOG( t + (- a - e - f)/2 )
     fact(3) = FacLOG( t + (- d - b - f)/2 )
     fact(4) = FacLOG( t + (- d - e - c)/2 )
     fact(5) = FacLOG(-t + (  a + b + d + e )/2 )
     fact(6) = FacLOG(-t + (  b + c + e + f )/2 )
     fact(7) = FacLOG(-t + (  c + a + f + d )/2 )

     temp = FacLOG(t+1) - ( fact(1) + fact(2) + fact(3) + fact(4) + fact(5) + fact(6) + fact(7))

     W6J2 = W6J2 + (-1)**(t) * EXP(temp)

!     W6J2 = W6J2 + (-1)**(t) * DBLE(FacLOG(t+1)) / &
!          & (fact(1)*fact(2)*fact(3)*fact(4)*fact(5)*fact(6)*fact(7))

  END DO

  Wigner_6j = W6J1 * W6J2

  RETURN

END FUNCTION Wigner_6j
!  .....................................................

!FUNCTION Wigner_6j2(j1,j2,j3,j4,j5,j6)
!  USE PRECISION
!  IMPLICIT NONE

!  ! calcultaes Wigner 6j Symbol
!  ! from the definition of 3j symbols
!  ! not efficient. just for check

!  ! j1/2 j2/2 j3/2 !
!  ! j4/2 j5/2 j6/2 !

!  INTERFACE
!     FUNCTION Wigner_3j (j1, j2, J, m1, m2, M)
!       USE PRECISION
!       IMPLICIT NONE
!       INTEGER, INTENT(IN) :: j1, j2, J, m1, m2, M
!       REAL (DP) :: Wigner_3j
!     END FUNCTION Wigner_3j
!  END INTERFACE

!  INTEGER, INTENT(IN) :: j1, j2, j3, j4, j5, j6
!  REAL(DP) :: Wigner_6j2
!  REAL(DP) :: W3j1, W3j2, W3j3, W3j4
!  INTEGER :: m1, m2, m3, m4, m5, m6, S, PHASE

!  Wigner_6j2 = 0.0D0

!  DO m1 = -j1, j1, 2
!  DO m2 = -j2, j2, 2
!  DO m3 = -j3, j3, 2
!  DO m4 = -j4, j4, 2
!  DO m5 = -j5, j5, 2
!  DO m6 = -j6, j6, 2

!     S = (j1+j2+j3+j4+j5+j6 - m1-m2-m3-m4-m5-m6)/2
!     PHASE = (-1)**S

!     W3j1 = Wigner_3j(j1, j2, j3, m1, m2,-m3)
!     W3j2 = Wigner_3j(j1, j5, j6,-m1, m5, m6)
!     W3j3 = Wigner_3j(j4, j5, j3, m4,-m5, m3)
!     W3j4 = Wigner_3j(j4, j2, j6,-m4,-m2,-m6)

!     Wigner_6j2 = Wigner_6j2 + PHASE * W3j1*W3j2*W3j3*W3j4

!  END DO
!  END DO
!  END DO
!  END DO
!  END DO
!  END DO

!  RETURN

!END FUNCTION Wigner_6j2

!FUNCTION Racah_V(j1,j2,J,m1,m2,M)
!  USE PRECISION
!  IMPLICIT NONE

!  INTERFACE

!     FUNCTION Wigner_3j (j1, j2, J, m1, m2, M)
!       USE PRECISION
!       IMPLICIT NONE
!       INTEGER, INTENT(IN) :: j1, j2, J, m1, m2, M
!       REAL (DP) :: Wigner_3j
!     END FUNCTION Wigner_3j

!  END INTERFACE

!  INTEGER, INTENT(IN) :: j1, j2, J, m1, m2, M

!  REAL(DP) :: Racah_V

!  Racah_V = (-1)**((-j1+j2+J)/2) * Wigner_3j(j1,j2,j1,m2,m1,m2)

!  RETURN

!END FUNCTION Racah_V

FUNCTION Racah_W(a,b,c,d,e,f)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

! W(a/2 b/2 c/2 d/2; e/2 f/2)

  INTERFACE

     FUNCTION Wigner_6j(a,b,c,d,e,f)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: a,b,c,d,e,f
       REAL(DP) :: Wigner_6j
     END FUNCTION Wigner_6j

  END INTERFACE

  INTEGER, INTENT(IN) :: a,b,c,d,e,f
  REAL(DP) :: Racah_W

  Racah_W = 0.0D0
  IF(MOD(a+b+c+d,2) .NE. 0) RETURN

  Racah_W = (-1)**((a+b+c+d)/2) * Wigner_6j(a,b,e,d,c,f)

  RETURN

END FUNCTION Racah_W

FUNCTION Wigner_9j(j1,j2,j3,j4,j5,j6,j7,j8,j9)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

! j1/2 j2/2 j3/2 !
! j4/2 j5/2 j6/2 !
! j7/2 j8/2 j9/2 !

  INTERFACE

  FUNCTION Wigner_6j(a,b,c,d,e,f)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: a,b,c,d,e,f
       REAL(DP) :: Wigner_6j
     END FUNCTION Wigner_6j

  END INTERFACE

  INTEGER, INTENT(IN) :: j1,j2,j3,j4,j5,j6,j7,j8,j9
  REAL(DP) :: Wigner_9j

  INTEGER :: x_min, x_max, x

  Wigner_9j = 0.0D0

  IF(j1 .LT. 0) RETURN
  IF(j2 .LT. 0) RETURN
  IF(j3 .LT. 0) RETURN
  IF(j4 .LT. 0) RETURN
  IF(j5 .LT. 0) RETURN
  IF(j6 .LT. 0) RETURN
  IF(j7 .LT. 0) RETURN
  IF(j8 .LT. 0) RETURN
  IF(j9 .LT. 0) RETURN

  x_min = MAX( ABS(j1-j9), ABS(j4-j8), ABS(j2-j6))
  x_max = MIN(     j1+j9,      j4+j8,      j2+j6)

  DO x = x_min, x_max

     Wigner_9j = Wigner_9j + (-1)**(x) * (x + 1.0D0) * &
          & Wigner_6j(j1,j4,j7,j8,j9, x)  * &
          & Wigner_6j(j2,j5,j8,j4, x,j6) * &
          & Wigner_6j(j3,j6,j9, x,j1,j2)

  END DO

  RETURN

END FUNCTION Wigner_9j

FUNCTION fm(I_Ang, K_Ang)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  INTEGER, INTENT(IN) :: I_Ang, K_Ang
  REAL(DP) :: fm

  fm = SQRT( (I_Ang + K_Ang) * (I_Ang - K_Ang + 2) / 4.0D0 )

END FUNCTION fm

FUNCTION fp(I_Ang, K_Ang)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  INTEGER, INTENT(IN) :: I_Ang, K_Ang
  REAL(DP) :: fp

  fp = SQRT( (I_Ang - K_Ang) * (I_Ang + K_Ang + 2) / 4.0D0 )

END FUNCTION fp

FUNCTION Wigner_smalld(j,m1,m2,beta)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
! -------------------------------
! Wigner's small d-function
! d^{j/2}_{m2/2,m1/2}(\theta)
! -------------------------------
  INTERFACE

     FUNCTION FacLOG(N)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
     INTEGER, INTENT(IN) :: N
     REAL(DP) ::  FacLOG
     END FUNCTION FacLOG
  END INTERFACE

  INTEGER,  INTENT(IN) :: j, m1, m2 ! doubled
  REAL(DP), INTENT(IN) :: beta      ! in radian

  REAL(DP) :: Wigner_smalld

  REAL(DP) :: fact(1:4), prefactor, mufactor
  INTEGER :: mu_min, mu_max, mu

  Wigner_smalld = 0.0D0

  fact(1) = FacLOG((j+m1)/2)
  fact(2) = FacLOG((j-m1)/2)
  fact(3) = FacLOG((j+m2)/2)
  fact(4) = FacLOG((j-m2)/2)

  prefactor = 0.50D0 * SUM(fact(1:4))
  prefactor = EXP(prefactor)

  mu_min = MAX(0, m1-m2)  /2
  mu_max = MIN(j-m2, j+m1)/2

  IF (mu_min .GT. mu_max) THEN
     Wigner_smalld = (mu_min - mu_max)*1.0D10
     RETURN
  END IF

  DO mu = mu_min, mu_max

     fact(1) = FacLOG((j-m2)/2-mu)
     fact(2) = FacLOG((j+m1)/2-mu)
     fact(3) = FacLOG(mu+(m2-m1)/2)
     fact(4) = FacLOG(mu)

     mufactor = (-1)**mu * EXP(-SUM(fact(1:4)))

     Wigner_smalld = Wigner_smalld + mufactor * (COS(0.50D0*beta))**((2*j+m1-m2)/2-2*mu) * (-SIN(0.50D0*beta))**((m2-m1)/2+2*mu)

  END DO

  Wigner_smalld = Wigner_smalld * prefactor

  RETURN

END FUNCTION Wigner_smalld

FUNCTION Wigner_Dmatrix(j,m1,m2,alpha,beta,gamma)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
  ! note that this returns D^\ast in the notation used in nuclear theory (Takada and Ikeda (A.16))
  INTERFACE

     FUNCTION Wigner_smalld(j,m1,m2,beta)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER,  INTENT(IN) :: j, m1, m2 ! doubled
       REAL(DP), INTENT(IN) :: beta      ! in radian
       REAL(DP) :: Wigner_smalld
     END FUNCTION Wigner_smalld
  END INTERFACE

  INTEGER, INTENT(IN) :: j, m1, m2
  REAL(DP), INTENT(IN) :: alpha,beta,gamma

  COMPLEX(DP) :: Wigner_Dmatrix, IUNIT = (0.0D0,1.0D0)

  Wigner_Dmatrix = EXP(-IUNIT*alpha*m2/2.0D0) * Wigner_smalld(j,m1,m2,beta) * EXP(-IUNIT*gamma*m1/2.0D0)

  RETURN

END FUNCTION Wigner_Dmatrix

FUNCTION HOB(NN, LL, n, l, n1, l1, n2, l2, Lambda, dd)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

  INTERFACE

     FUNCTION FacLOG(N)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: N
       REAL(DP) ::  FacLOG
     END FUNCTION FacLOG

     FUNCTION Triangle(a,b,c)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: a,b,c
       REAL(DP) :: Triangle
     END FUNCTION Triangle

     FUNCTION DBLEFacLOG(N)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: N
       REAL(DP) ::  DBLEFacLOG
     END FUNCTION DBLEFacLOG

     FUNCTION Wigner_9j(j1,j2,J12,j3,j4,J34,J13,J24,J)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: j1,j2,J12,j3,j4,J34,J13,J24,J
       REAL(DP) :: Wigner_9j
     END FUNCTION Wigner_9j

     FUNCTION CG(j1, m1, j2, m2, J, M)
     IMPLICIT NONE
     INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)
       INTEGER, INTENT(IN) :: j1, j2, m1, m2, J, M
       REAL(DP) :: CG
     END FUNCTION CG

!     FUNCTION Wigner_6j2(a,b,c,d,e,f)
!       USE PRECISION
!       IMPLICIT NONE
!       INTEGER, INTENT(IN) :: a,b,c,d,e,f
!       REAL(DP) :: Wigner_6j2
!     END FUNCTION Wigner_6j2

  END INTERFACE

  INTEGER,  INTENT(IN) :: NN, LL, n, l, n1, l1, n2, l2, Lambda
  REAL(DP), INTENT(IN) :: dd
  REAL(DP)             :: HOB

  REAL(DP) :: PREFACTOR, FACTOR, PHASE, PHASE1
  REAL(DP) :: term1,term2,term3,term4,term5,term6,term7,term8,term9
  INTEGER :: e, EE, e1, e2, a, b, c, d, la, lb, lc, ld
  INTEGER :: ea, eb, ec, ed

!  REAL(DP) :: Wigner_6j

! equation from nucl-th/0105009v1

! major oscillator quantum numbers
  e  = 2*n +l
  EE = 2*NN+LL
  e1 = 2*n1+l1
  e2 = 2*n2+l2

  HOB = 0.0D0
  IF (e+EE - (e1+e2) .NE. 0) RETURN
  IF(MOD(l1+l2+LL+l,2) .NE. 0) RETURN

  PHASE = (-1)**(-(l1+l2+LL+l)/2)

  PREFACTOR = 0.50D0 * ( FacLOG(n1) + FacLOG(n2) + FacLOG(NN) + FacLOG(n) + DBLEFacLOG(2*(n1+l1)+1) &
       & + DBLEFacLOG(2*(n2+l2)+1) + DBLEFacLOG(2*(NN+LL)+1) + DBLEFacLOG(2*(n+l)+1) ) &
       & - (l1+l2+LL+l)/4.0D0*LOG(2.0D0)
  PREFACTOR = EXP(PREFACTOR)

  FACTOR = 0.0D0

  LOOP1: DO a =  0, MIN(e1/2,EE/2) ! approx
  LOOP2: DO la = 0, MIN(e1, EE)
     ea = 2*a + la
  LOOP3: DO b =  0, MIN(e1/2, e/2)
  LOOP4: DO lb = 0, MIN(e1,  e)
     eb = 2*b + lb
     IF(ea + eb - e1 .NE. 0) CYCLE LOOP4
     IF(ABS(Triangle(2*la,2*lb,2*l1)) .LT. 1.0D-10) CYCLE LOOP4
  LOOP5: DO c =  0, MIN(e2/2,EE/2)
  LOOP6: DO lc = 0, MIN(e2, EE)
     ec = 2*c + lc
     IF(ea + ec - EE .NE. 0) CYCLE LOOP6
     IF(ABS(Triangle(2*la,2*lc,2*LL)) .LT. 1.0D-10) CYCLE LOOP6
  LOOP7: DO d =  0, MIN(e2/2, e/2)
  LOOP8: DO ld = 0, MIN(e2,  e)
     ed = 2*d + ld
     IF(ec + ed - e2 .NE. 0) CYCLE LOOP8
     IF(eb + ed -  e .NE. 0) CYCLE LOOP8
     IF(ABS(Triangle(2*lc,2*ld,2*l2)) .LT. 1.0D-10) CYCLE LOOP8
     IF(ABS(Triangle(2*lb,2*ld,2*l )) .LT. 1.0D-10) CYCLE LOOP8

     PHASE1 = (-1)**(la+lb+lc)
     term1 = 2.0D0**((la+lb+lc+ld)/2.0D0)
     term2 = dd**((ea + ed)/2.0D0)
     term3 = (1.0D0+dd)**(-(ea + eb + ec + ed)/2.0D0)

     term4 = - FacLOG(a) - FacLOG(b) - FacLOG(c) - FacLOG(d) &
          & - DBLEFacLOG(2*(a+la)+1) - DBLEFacLOG(2*(b+lb)+1) - DBLEFacLOG(2*(c+lc)+1) - DBLEFacLOG(2*(d+ld)+1)
     term4 = EXP(term4)
     term4 = term4 * (2*la+1)*(2*lb+1)*(2*lc+1)*(2*ld+1)

     term5 = Wigner_9j(2*la,2*lb,2*l1,2*lc,2*ld,2*l2,2*LL,2*l,2*Lambda)
     term6 = CG(2*la, 0, 2*lc, 0, 2*LL, 0)
     term7 = CG(2*lb, 0, 2*ld, 0, 2*l,  0)
     term8 = CG(2*la, 0, 2*lb, 0, 2*l1, 0)
     term9 = CG(2*lc, 0, 2*ld, 0, 2*l2, 0)

     FACTOR = FACTOR +  PHASE1*term1*term2*term3*term4*term5*term6*term7*term8*term9

  END DO LOOP8
  END DO LOOP7
  END DO LOOP6
  END DO LOOP5
  END DO LOOP4
  END DO LOOP3
  END DO LOOP2
  END DO LOOP1

  ! phase convention of NPA600
  HOB = PHASE * PREFACTOR * FACTOR

  ! phase convention of Moshinsky
!  HOB = HOB * (-1)**(LL+l+Lambda)

  RETURN

END FUNCTION HOB

      SUBROUTINE CJJ (J1,J2,J3,M1,M2,M3,C)
!     CLEBSH-GORDON COEFFICIENTS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON IOUT,IREAD,IPRI,IPREC,CAS
      COMMON /CLOG/ FLOG(100)
      C=0.0D0
      IF (M1+M2-M3) 1000,112, 1000
  112 N=J1+J2-J3
      IF(N)1000,120,120
  120 KK1=N/2
      IF (KK1+KK1-N) 1000, 130, 1000
  130 MMX=KK1
      N=J3+J1-J2
      IF(N)1000,140,140
  140 K2=N/2
      IF(K2+K2-N)1000,150,1000
  150 N=J3+J2-J1
      IF(N)1000,160,160
  160 K3=N/2
      IF(K3+K3-N)1000,170,1000
  170 K4=(J1+J2+J3)/2+1
      N=J1+M1
      IF(N)1000,180,180
  180 K5=N/2
      IF(K5+K5-N)1000,190,1000
  190 S = FLOG(KK1+1)+FLOG(K2+1)+FLOG(K3+1)-FLOG(K4+1)+FLOG(K5+1)
      N=J1-M1
      IF (N) 1000, 210, 210
  210 KK2=N/2
      IF (KK2+KK2-N) 1000, 220, 1000
  220 IF (MMX-KK2) 240, 240, 230
  230 MMX=KK2
  240 N=J2+M2
      IF(N)1000,250,250
  250 KK3=N/2
      IF (KK3+KK3-N) 1000, 260, 1000
  260 IF (MMX-KK3) 280, 280, 270
  270 MMX=KK3
  280 N=J2-M2
      IF(N)1000,290,290
  290 K3=N/2
      IF(K3+K3-N)1000,300,1000
  300 N=J3+M3
      IF(N)1000,310,310
  310 K4=N/2
      IF(K4+K4-N)1000,320,1000
  320 N=J3-M3
      IF(N)1000,330,330
  330 K5=N/2
      IF(K5+K5-N)1000,340,1000
  340 S = (S+FLOG(KK2+1)+FLOG(KK3+1)+FLOG(K3+1)                &
     &     +FLOG(K4+1)+FLOG(K5+1))*0.5D0
      N=J3-J2+M1
      KK4=N/2
      IF (KK4+KK4-N) 1000, 345, 1000
  345 IF(N)350,360,360
  350 MMN=-KK4
      GO TO 370
  360 MMN=0
  370 N=J3-J1-M2
      KK5=N/2
      IF (KK5+KK5-N) 1000, 375, 1000
  375 IF(N)380,400,400
  380 IF (KK5+MMN) 390, 400, 400
  390 MMN=-KK5
  400 N=MMN/2
      K1=N+N-MMN
      IF(K1)410,420,420
  410 SIGN=-1.0D0
      GO TO 500
  420 SIGN=1.0D0
  500 SUM= 0.0D0
      IF (MMX-MMN) 1000, 510, 510
  510 DO 600 MU=MMN,MMX
      K1=KK1-MU
      K2=KK2-MU
      K3=KK3-MU
      K4=KK4+MU
      K5=KK5+MU
      T=S-FLOG(MU+1)-FLOG(K1+1)-FLOG(K2+1)-FLOG(K3+1) &
     &   -FLOG(K4+1)-FLOG(K5+1)
      SUM=SUM+SIGN*EXP (T)
      SIGN=-SIGN
  600 CONTINUE
      S=J3+1
      C=SUM*SQRT (S)
 1000 RETURN
      END


MODULE Update_EWMA

! Update exponentially weighted moving averages (EWMA) & variances.
! New average = lambda.x + (1 - lambda).(old average)
! The variance of the estimated mean = [lambda/(2 - lambda)].variance(x)

! Code by Alan Miller
! amiller@bigpond.net.au
! Web sites:
! http://www.ozemail.com.au/~milleraj/
! http://users.bigpond.net.au/amiller

! Latest revision - 24 October 2001

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

REAL (dp), SAVE, PRIVATE  :: lambda, one_lambda, deg_freedom
LOGICAL, SAVE, PRIVATE    :: initialized = .FALSE.

CONTAINS

SUBROUTINE initialize(l)

REAL (dp), INTENT(IN)  :: l

lambda = l
initialized = .TRUE.
one_lambda = 1.0_dp - lambda
deg_freedom = 2.0_dp * one_lambda / (lambda*(2.0_dp - lambda))

RETURN
END SUBROUTINE initialize

SUBROUTINE update(x, average, sumsq)

! New average = lambda.x + (1 - lambda).(old average)

REAL (dp), INTENT(IN)      :: x
REAL (dp), INTENT(IN OUT)  :: average, sumsq

! Local variable
REAL (dp)  :: dev

! For speed, the following lines are not used
! IF (.NOT. initialized) THEN
!   WRITE(*, *) ' *** EWMA not initialized ***'
!   STOP
! END IF

dev = x - average
average = average + lambda * dev
sumsq = one_lambda * sumsq + dev * (x - average)

RETURN
END SUBROUTINE update

FUNCTION variance(sumsq) RESULT(fn_val)

! Calculate the variance from the sum of squares.

REAL (dp), INTENT(IN)  :: sumsq
REAL (dp)              :: fn_val

fn_val = sumsq / deg_freedom

RETURN
END FUNCTION variance

END MODULE Update_EWMA

PROGRAM test_EWMA

! Generate random normal values with mean = 7.0 and variance = 1.0
! Calculate and output the weighted average and variance after every 10 values.

USE Update_EWMA
IMPLICIT NONE

REAL (dp)  :: lambda, x, average, sumsq
INTEGER    :: i

WRITE(*, '(a)', ADVANCE='NO') ' Enter lambda between 0 and 1: '
READ(*, *) lambda
CALL initialize(lambda)

! Set arbitrary starting values for average & sumsq
average = 5.0_dp
sumsq = 1.0_dp

WRITE(*, '(a, f6.2)') ' Lambda = ', lambda
WRITE(*, *) '  I     Avge.  Variance'
DO i = 1, 1000
  x = rnorm() + 7.0
  CALL update(x, average, sumsq)
  IF (i == 10*(i/10)) THEN
    WRITE(*, '(i5, f7.1, f7.1)') i, average, variance(sumsq)
  END IF
END DO

STOP

CONTAINS

FUNCTION rnorm() RESULT( fn_val )

!   Generate a random normal deviate using the polar method.
!   Reference: Marsaglia,G. & Bray,T.A. 'A convenient method for generating
!              normal variables', Siam Rev., vol.6, 260-264, 1964.

IMPLICIT NONE
REAL  :: fn_val

! Local variables

REAL            :: u, sum
REAL, SAVE      :: v, sln
LOGICAL, SAVE   :: second = .FALSE.
REAL, PARAMETER :: one = 1.0, vsmall = TINY( one )

IF (second) THEN
! If second, use the second random number generated on last call

  second = .false.
  fn_val = v*sln

ELSE
! First call; generate a pair of random normals

  second = .true.
  DO
    CALL RANDOM_NUMBER( u )
    CALL RANDOM_NUMBER( v )
    u = SCALE( u, 1 ) - one
    v = SCALE( v, 1 ) - one
    sum = u*u + v*v + vsmall         ! vsmall added to prevent LOG(zero) / zero
    IF(sum < one) EXIT
  END DO
  sln = SQRT(- SCALE( LOG(sum), 1 ) / sum)
  fn_val = u*sln
END IF

RETURN
END FUNCTION rnorm

END PROGRAM test_EWMA


program check
    use device
    implicit none

    logistic_map: block
        use uniplot
!        use xplot
!        use psplot
        class(device_t), allocatable :: fig
        integer :: ix, i, nx = 150, ny = 80
        real :: p, x, y
        allocate(fig_t::fig)
        print *,  'logistic map'
        call fig%init(nx, ny, 'Loggistic_map')
        do ix = 1, nx
            p = 0.3
            x = ix * (3.0 - 1.5) / nx + 1.5
            do i = 1, 50
                p = p + x * p * (1.0 - p)
            end do
            do i = 51, 100
                y = p / 1.5 * ny
                call fig%point(ix, nint(1.0*(ny - y)))
                p = p + x * p * (1 - p)
            end do
        end do
        call fig%show()
    end block logistic_map

    Lorenz_attractor: block
        use uniplot
!        use xplot
!        use psplot
        class(device_t), allocatable :: fig
        integer, parameter :: kd = kind(1.0d0)
        real (kd) :: x, y, z, dx, dy, dz, a, b, c, d
        integer :: k, nx = 200, ny = 200
        real :: scale
        allocate(fig_t::fig)
        print *,  'Lorenz attractor'
        scale = 2.0
        call fig%init(nx, ny, 'Lorenz_attractor')
        a = 10.0_kd
        b = 28.0_kd
        c = 8.0_kd / 3.0_kd
        d = 0.01_kd
        x = 1.0_kd
        y = 1.0_kd
        z = 1.0_kd
        do k = 1, 3000
            dx = a * (y - x)
            dy = x * (b - z) - y
            dz = x * y - c * z
            x = x + d * dx
            y = y + d * dy
            z = z + d * dz
            if (k < 100) then
                call fig%line( scale * real(x), scale * real(z), 0)
            else
                call fig%line( scale * real(x), scale * real(z), 1)
            end if
        end do
        call fig%show()
    end block Lorenz_attractor

    Laplaces_equation: block
!        use uniplot
!        use xplot
        use psplot
!        use htmlplot
        class(device_t), allocatable :: fig
        real :: x, y, v(-50:50, -50:50)
        integer :: i, j
        allocate(fig_t::fig)               !
        print *,  'Laplace''s equation'
        call fig%init(150, 170, 'Laplaces_equation')
        call laplace(v)
! x-direction
        do i = lbound(v, 2), ubound(v, 2), 10
            x = lbound(v, 2) + 0.2 * i
            y = 30.0 - 0.4 * i
            call fig%line(x, y, 0)
            do j = lbound(v, 1), ubound(v, 1), 10
                x = j + 0.2 * i
                y = 30.0 - 0.4 * i - 2.0 * v(j, i)
                call fig%line(x, y, 1)
            end do
        end do
! y-direction
        do j = lbound(v, 1), ubound(v, 1), 10
            x = j + 0.2 * lbound(v, 2)
            y = 30.0 - 0.4 * lbound(v, 2)
            call fig%line(x, y, 0)
            do i = lbound(v, 2), ubound(v, 2), 10
                x = j + 0.2 * i
                y = 30.0 - 0.4 * i - 2.0 * v(j, i)
                call fig%line(x, y, 1)
            end do
        end do
        call fig%show()
    end block Laplaces_equation

    Abe_san: block
!        use uniplot
        !use htmlplot
        use xplot
        class(device_t), allocatable :: fig1
        allocate(fig_t::fig1)
        call fig1%init(450, 450, 'Abe_san')
        ! chin chin
        call fig1%line(  0.0,  11.0, 0)
        call fig1%line(  0.0,   8.0, 1)

        call fig1%line( -8.0, -26.5, 0)
        call fig1%line(-11.0, -24.0, 1)
        call fig1%line(  8.0, -26.5, 0)
        call fig1%line( 11.0, -24.0, 1)

        call fig1%line(  5.5, -26.0, 0)
        call fig1%line(  2.0, -36.0, 1)
        call fig1%line( -5.5, -26.0, 0)
        call fig1%line( -2.0, -36.0, 1)

        call fig1%line( 20.0, -18.0, 0)
        call fig1%line(  8.5, -19.0, 1)
        call fig1%line(  4.0, -21.5, 1)
        call fig1%line(  0.0, -23.0, 1)
        call fig1%line( -4.0, -21.5, 1)
        call fig1%line( -8.5, -19.0, 1)
        call fig1%line(-20.0, -18.0, 1)

        call fig1%line( 12.0, -16.0, 0)
        call fig1%line( 22.0,  14.0, 1)
        call fig1%line(-12.0, -16.0, 0)
        call fig1%line(-22.0,  14.0, 1)

        call fig1%line( 53.0,  -9.0, 0)
        call fig1%line( 28.5,   1.0, 1)
        call fig1%line( 28.5, -14.0, 0)
        call fig1%line( 28.5,  25.0, 1)
        call fig1%line( 28.5,  33.0, 0)
        call fig1%line( 28.5,  76.0, 1)
        call fig1%line( -2.5,  76.0, 1)
        call fig1%line( -2.5,  72.0, 1)
        call fig1%line( -0.5,  68.0, 1)
        call fig1%line(  1.0,  66.0, 1)
        call fig1%line( -1.5,  67.0, 1)
        call fig1%line( -4.0,  72.0, 1)
        call fig1%line( -4.0,  76.0, 1)
        call fig1%line(-28.5,  76.0, 1)
        call fig1%line(-28.5,  33.0, 1)

        call fig1%line(-28.5,  25.0, 0)
        call fig1%line(-28.5, -14.0, 1)
        call fig1%line(-53.0,  -9.0, 0)
        call fig1%line(-28.5,   1.0, 1)

        call fig1%line(  0.0,   0.0, 0)
        call fig1%line(  6.5,   0.0, 1)
        call fig1%line( 10.0,   3.0, 1)
        call fig1%line( 15.0,   7.0, 1)
        call fig1%line( 22.0,  14.0, 1)
        call fig1%line( 28.5,  25.0, 1)
        call fig1%line( 31.0,  26.0, 1)
        call fig1%line( 35.0,  34.0, 1)
        call fig1%line( 38.0,  44.0, 1)
        call fig1%line( 38.0,  53.0, 1)
        call fig1%line( 36.0,  55.0, 1)
        call fig1%line( 32.0,  55.0, 1)
        call fig1%line( 28.5,  51.0, 1)

        call fig1%line(  0.0,   0.0, 0)
        call fig1%line( -6.5,   0.0, 1)
        call fig1%line(-10.0,   3.0, 1)
        call fig1%line(-15.0,   7.0, 1)
        call fig1%line(-22.0,  14.0, 1)
        call fig1%line(-28.5,  25.0, 1)
        call fig1%line(-31.0,  26.0, 1)
        call fig1%line(-35.0,  34.0, 1)
        call fig1%line(-38.0,  44.0, 1)
        call fig1%line(-38.0,  53.0, 1)
        call fig1%line(-36.0,  55.0, 1)
        call fig1%line(-32.0,  55.0, 1)
        call fig1%line(-28.5,  51.0, 1)

        call fig1%line( 34.0,  55.0, 0)
        call fig1%line( 34.0,  76.0, 1)
        call fig1%line( 31.0,  82.0, 1)
        call fig1%line( 26.0,  87.0, 1)
        call fig1%line( 21.0,  91.0, 1)
        call fig1%line( 15.0,  95.0, 1)
        call fig1%line(  0.0,  95.0, 1)

        call fig1%line(-34.0,  55.0, 0)
        call fig1%line(-34.0,  76.0, 1)
        call fig1%line(-31.0,  82.0, 1)
        call fig1%line(-26.0,  87.0, 1)
        call fig1%line(-21.0,  91.0, 1)
        call fig1%line(-15.0,  95.0, 1)
        call fig1%line(  0.0,  95.0, 1)

        ! nose
        call fig1%line( -5.0, 41.0, 0)
        call fig1%line( -4.0, 40.0, 1)
        call fig1%line(  0.0, 40.0, 1)
        call fig1%line(  2.0, 42.0, 1)
        call fig1%line(  3.0, 42.0, 1)
        call fig1%line(  5.5, 37.0, 1)
        call fig1%line(  5.0, 37.0, 1)
        call fig1%line(  4.0, 38.5, 1)
        call fig1%line(  0.5, 38.5, 1)
        call fig1%line(  0.0, 37.0, 1)
        call fig1%line( -2.0, 37.0, 1)
        call fig1%line( -3.0, 38.5, 1)
        call fig1%line( -7.0, 38.5, 1)
        call fig1%line( -8.0, 37.0, 1)
        call fig1%line( -8.5, 40.0, 1)
        call fig1%line( -4.0, 45.0, 1)
        call fig1%line( -4.0, 54.0, 1)
        call fig1%line( -5.0, 55.0, 1)

        call fig1%line( -6.0, 53.0, 0)
        call fig1%line( -5.0, 53.0, 1)
        call fig1%line( -5.0, 47.0, 1)
        call fig1%line( -7.5, 46.0, 1)
        call fig1%line( -6.0, 53.0, 1)

        ! left eye
        call fig1%line(-24.0, 55.0, 0)
        call fig1%line(-22.0, 53.0, 1)
        call fig1%line(-17.0, 54.5, 1)
        call fig1%line( -8.0, 55.0, 1)
        call fig1%line( -7.0, 55.5, 1)
        call fig1%line( -8.5, 56.5, 1)
        call fig1%line(-24.0, 55.0, 1)

        call fig1%line( -8.0, 54.5, 0)
        call fig1%line(-12.0, 52.5, 1)

        call fig1%line(-23.0, 56.0, 0)
        call fig1%line(-21.5, 57.0, 1)
        call fig1%line(-10.0, 58.0, 1)
        call fig1%line( -9.0, 57.0, 1)

        ! left eyebrow
        call fig1%line(-27.5, 56.5, 0)
        call fig1%line(-24.0, 59.0, 1)
        call fig1%line(-11.0, 59.5, 1)
        call fig1%line( -7.0, 61.0, 1)
        call fig1%line( -4.0, 65.0, 1)
        call fig1%line( -9.0, 63.0, 1)
        call fig1%line(-25.0, 62.0, 1)
        call fig1%line(-27.5, 56.5, 1)

        ! right eyebrow
        call fig1%line( 27.5, 56.5, 0)
        call fig1%line( 24.0, 59.0, 1)
        call fig1%line( 11.0, 59.5, 1)
        call fig1%line(  7.0, 61.0, 1)
        call fig1%line(  4.0, 65.0, 1)
        call fig1%line(  9.0, 63.0, 1)
        call fig1%line( 25.0, 62.0, 1)
        call fig1%line( 27.5, 56.5, 1)

        ! right eye
        call fig1%line( 19.0, 53.0, 0)
        call fig1%line( 23.0, 55.0, 1)
        call fig1%line( 16.0, 55.0, 1)
        call fig1%line(  9.0, 56.0, 1)
        call fig1%line(  9.5, 55.0, 1)
        call fig1%line( 19.0, 53.0, 1)

        call fig1%line(  9.0, 58.0, 0)
        call fig1%line( 12.0, 58.0, 1)
        call fig1%line( 19.0, 56.0, 1)
        call fig1%line( 21.5, 56.0, 1)

        call fig1%line(  0.0, 29.0, 0)
        call fig1%line(  5.0, 29.0, 1)
        call fig1%line( 11.0, 27.0, 1)
        call fig1%line(  6.0, 32.0, 1)
        call fig1%line(  0.0, 30.0, 1)
        call fig1%line( -6.0, 32.0, 1)
        call fig1%line(-11.0, 27.0, 1)
        call fig1%line( -5.0, 29.0, 1)
        call fig1%line(  0.0, 29.0, 1)

        call fig1%line(-6.5, 21.5, 0)
        call fig1%line(-3.5, 20.0, 1)
        call fig1%line( 3.5, 20.0, 1)
        call fig1%line( 6.5, 21.5, 1)
        call fig1%line(-5.0, 21.0, 0)
        call fig1%line( 5.0, 21.0, 1)
        call fig1%show()
    end block Abe_san

contains

    subroutine laplace(v)
        real, intent(out) :: v(-50:50, -50:50)
        logical :: mask(lbound(v, 1):ubound(v, 1), lbound(v, 2):ubound(v, 2))
        integer :: i, j, iter
        mask = .true.
        mask(-10, -25:25) = .false. ! static voltage
        mask( 10, -25:25) = .false.
        v = 0.0
        v(-10, -25:25) =  10.0
        v( 10, -25:25) = -10.0
      !
        do iter = 1, 200
            forall (i = lbound(v, 1) + 1:ubound(v, 1) - 1, j = lbound(v, 2) + 1:ubound(v, 2) - 1, mask(i, j))
                v(i, j) = 0.25 * ( v(i - 1, j) + v(i + 1, j) + v(i, j - 1) + v(i, j + 1) )
            end forall
        end do
    end subroutine laplace
end program check


!	cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!	quad3d8n.fcm                                                         c
!	---------------------------------------------------------------------c
!     quadrature definitions in three dimensional quad reference domain    c
!	---------------------------------------------------------------------c
!	920422 - written                                                     c
!	930311 - removed initialization of xquad                             c
!	cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine quad3d8n(iquad, nquad, xquad, wquad, maxnsd, maxnquad)

	real* 8 xquad(maxnsd,maxnquad)
	real* 8 wquad(maxnquad)

      logical     twod
      common /twodimension/ twod

	if ((iquad.eq.1).or.(iquad.eq.111111)) then
!		1 x 1 x 1 Gaussian quadrature - code 1.1,1.1,1.1 - old code 1
		nquad = 1

		xquad(1,1) = + 0.000000000000000
		xquad(2,1) = + 0.000000000000000
		xquad(3,1) = + 0.000000000000000

		wquad(1) = 8.0
		return

	else if ((iquad.eq.2).or.(iquad.eq.121212)) then
!		2 x 2 x 2 Gaussian quadrature - code 1.2,1.2,1.2 - old code 2
		nquad = 8
		xquad(1,1) = - 0.577350269189626
		xquad(2,1) = - 0.577350269189626
		xquad(3,1) = - 0.577350269189626
		xquad(1,2) = + 0.577350269189626
		xquad(2,2) = - 0.577350269189626
		xquad(3,2) = - 0.577350269189626
		xquad(1,3) = - 0.577350269189626
		xquad(2,3) = + 0.577350269189626
		xquad(3,3) = - 0.577350269189626
		xquad(1,4) = + 0.577350269189626
		xquad(2,4) = + 0.577350269189626
		xquad(3,4) = - 0.577350269189626
		xquad(1,5) = - 0.577350269189626
		xquad(2,5) = - 0.577350269189626
		xquad(3,5) = + 0.577350269189626
		xquad(1,6) = + 0.577350269189626
		xquad(2,6) = - 0.577350269189626
		xquad(3,6) = + 0.577350269189626
		xquad(1,7) = - 0.577350269189626
		xquad(2,7) = + 0.577350269189626
		xquad(3,7) = + 0.577350269189626
		xquad(1,8) = + 0.577350269189626
		xquad(2,8) = + 0.577350269189626
		xquad(3,8) = + 0.577350269189626

		wquad(1) = 1.0
		wquad(2) = 1.0
		wquad(3) = 1.0
		wquad(4) = 1.0
		wquad(5) = 1.0
		wquad(6) = 1.0
		wquad(7) = 1.0
		wquad(8) = 1.0
		return
	else
		call error("quad3d8n: unknown quadrature code ", iquad, .true.)
	end if

	end


!@sum  UTILDBL Model Independent Utilities
!@auth Original Development Team
!@ver  1.0
!@cont THBAR,QSAT,DQSATDT,TRIDIAG,FILEMANAGER,READT,DREAD,MREAD

      FUNCTION THBAR (X,Y)
!@sum  THBAR calculates mean temperature used in vertical differencing
!@auth Gary Russell, Jean Lerner, Arakawa
!@ver  1.0
C****
C**** THBAR(T1,T2) = (ln(T1) - ln(T2))/(1/T2 - 1/T1)
C****              = T1*g(x) with x=T1/T2 , g(x)=ln(x)/(x-1)
C****      g(x) is replaced by a rational function
C****           (a+bx+cxx+dxxx+cx**4)/(e+fx+gxx)
C****      approx.error <1.E-6 for x between .9 and 1.7
C****
      IMPLICIT NONE
!@var A,B,C,D,E,F,G   expansion coefficients for THBAR
      REAL*8, PARAMETER :: A=113.4977618974100d0
      REAL*8, PARAMETER :: B=438.5012518098521d0
      REAL*8, PARAMETER :: C=88.49964112645850d0
      REAL*8, PARAMETER :: D=-11.50111432385882d0
      REAL*8, PARAMETER :: E=30.00033943846368d0
      REAL*8, PARAMETER :: F=299.9975118132485d0
      REAL*8, PARAMETER :: G=299.9994728900967d0
      REAL*8 :: Q,AL                 !@var Q,AL   working variables
      REAL*8, INTENT(IN) :: X,Y      !@var X,Y    input temperatures
      REAL*8 :: THBAR                !@var THBAR  averaged temperature
      Q=X/Y
      AL=(A+Q*(B+Q*(C+Q*(D+Q))))/(E+Q*(F+G*Q))
      THBAR=X*AL
      RETURN
      END

      FUNCTION QSAT (TM,QL,PR)
!@sum  QSAT calculates saturation vapour mixing ratio
!@auth Gary Russell
!@ver  1.0
      USE CONSTANT, only : mrat,rvap,tf
      IMPLICIT NONE
!@var A,B,C   expansion coefficients for QSAT
      REAL*8, PARAMETER :: A=6.108d0*MRAT    !3.797915d0
      REAL*8, PARAMETER :: B= 1./(RVAP*TF)   !7.93252d-6
      REAL*8, PARAMETER :: C= 1./RVAP        !2.166847d-3
C**** Note that if QL is considered to be a function of temperature, the
C**** correct argument in QSAT is the average QL from t=0 (C) to TM, ie.
C**** QL = 0.5*(QL(0)+QL(t))
      REAL*8, INTENT(IN) :: TM  !@var TM   potential temperature (K)
      REAL*8, INTENT(IN) :: PR  !@var PR   air pressure (mb)
      REAL*8, INTENT(IN) :: QL  !@var QL   lat. heat of vap./sub. (J/kg)
      REAL*8 :: QSAT            !@var QSAT sat. vapour mixing ratio
      QSAT = A*EXP(QL*(B-C/TM))/PR
      RETURN
      END

      FUNCTION DQSATDT (TM,QL)
!@sum  DQSATDT calculates change of sat. vapour mixing ratio with temp.
!@auth Gary Russell
!@ver  1.0
C**** Note that d(qsat)/dt = qsat * ql * c / T*T
C**** Only the factor of qsat is given here
      USE CONSTANT, only : rvap
      IMPLICIT NONE
!@var C coefficient for QSAT
      REAL*8, PARAMETER :: C = 1./RVAP        !2.166847d-3
C**** Note that if QL is considered to be a function of temperature, the
C**** correct argument in DQSATDT is the actual QL at TM i.e. QL=QL(TM)
      REAL*8, INTENT(IN) :: TM  !@var TM   potential temperature (K)
      REAL*8, INTENT(IN) :: QL  !@var QL   lat. heat of vap./sub. (J/kg)
      REAL*8 :: DQSATDT         !@var DQSATDT d(qsat)/dT factor only.
      DQSATDT = QL*C/(TM*TM)    ! * QSAT(TM,QL,PR)
      RETURN
      END

      SUBROUTINE TRIDIAG(A,B,C,R,U,N)
!@sum  TRIDIAG  solves a tridiagonal matrix equation (A,B,C)U=R
!@auth Numerical Recipes
!@ver  1.0
      IMPLICIT NONE
      INTEGER, PARAMETER :: NMAX = 5000  !@var NMAX workspace
      INTEGER, INTENT(IN):: N         !@var N    dimension of arrays
      REAL*8, INTENT(IN) :: A(N)   !@var A    coefficients of u_i-1
      REAL*8, INTENT(IN) :: B(N)   !@var B    coefficients of u_i
      REAL*8, INTENT(IN) :: C(N)   !@var C    coefficients of u_i+1
      REAL*8, INTENT(IN) :: R(N)   !@var R    RHS vector
      REAL*8, INTENT(OUT):: U(N)   !@var U    solution vector
      REAL*8 :: BET                   !@var BET  work variable
      REAL*8 :: GAM(NMAX)             !@var GAM  work array
      INTEGER :: J                    !@var J    loop variable

      IF ( N > NMAX )
     &     call stop_model("TRIDIAG: N > NMAX, increase NMAX",255)
      BET=B(1)
      IF (BET.eq.0) call stop_model("TRIDIAG: DENOMINATOR = ZERO",255)
      U(1)=R(1)/BET
      DO J=2,N
        GAM(J)=C(J-1)/BET
        BET=B(J)-A(J)*GAM(J)
        IF (BET.eq.0) call stop_model("TRIDIAG: DENOMINATOR = ZERO",255)
        U(J)=(R(J)-A(J)*U(J-1))/BET
      END DO
      DO J=N-1,1,-1
        U(J)=U(J)-GAM(J+1)*U(J+1)
      END DO
      RETURN
      END

      MODULE FILEMANAGER
!@sum  FILEMANAGER keeps data concerning the files and unit numbers
!@ver  2.0
      implicit none
      save
      private

      public openunit, closeunit, print_open_units
      public openunits, closeunits, nameunit

!@param MINUNIT, MAXUNIT - min and max unit number allowed
      integer, parameter :: MINUNIT = 50, MAXUNIT = 98
      integer, parameter :: TOTALUNITS = MAXUNIT-MINUNIT+1

      type UnitStr
        logical in_use                     ! is the unit in use or not
        character*16 filename              ! the name on the file
      end type UnitStr

      type (UnitStr) :: Units( MINUNIT:MAXUNIT ) = UnitStr(.false.," ")

      contains

      function nameunit( unit )
!@sum nameunit returns the name of the file corresponding to unit <unit>
      implicit none
      character*16 nameunit
      integer, intent(in) :: unit

      if ( unit>MAXUNIT .or. unit<MINUNIT
     $     .or. .not. Units(unit)%in_use ) then
        write(6,*) "FILEMANAGER: asked name of a wrong unit: ",unit
        call stop_model("FILEMANAGER: asked name of a wrong unit",255)
      endif
      nameunit = Units(unit)%filename
      end function nameunit

      subroutine findunit( unit )
!@sum findunit finds available unit
      implicit none
      integer, intent(out) :: unit

      do unit=MINUNIT,MAXUNIT
        if ( .not. Units(unit)%in_use ) return
      enddo
      write(6,*) "FILEMANAGER: Maximum file number reached"
      call print_open_units
      call stop_model("FILEMANAGER: Maximum file number reached",255)
      end subroutine findunit

      subroutine openunit( filename, iunit, qbin, qold )
!@sum openunit opens the file <filename> and returns its unit in <unit>
      implicit none
!@var unit - unit of opened file
      integer, intent(out) :: iunit
!@var filename - name of the file to open
      character*(*), intent(in) :: filename
!@var qbin - .true. if file is binary (.false. by default)
!@var qold - .true. if file is old (.false. by default)
      logical, optional, intent(in) :: qbin, qold
      character*11 form, status
      integer name_len

C**** set default options
      form = "FORMATTED"
      status = "UNKNOWN"
C**** parse options
      if( present(qbin) ) then
         if( qbin ) form = "UNFORMATTED"
      end if
      if( present(qold) ) then
         if( qold ) status = "OLD"
      end if

      call findunit( iunit )

      if ( form == "FORMATTED" ) then
        open( iunit, FILE=filename, FORM=form, STATUS=status,
#ifdef CONVERT_BIGENDIAN
     *       CONVERT='BIG_ENDIAN',
#endif
     *       RECL=65534, ERR=10 )
      else
        open( iunit, FILE=filename, FORM=form, STATUS=status,
#ifdef CONVERT_BIGENDIAN
     *       CONVERT='BIG_ENDIAN',
#endif
     *       ERR=10 )
      endif

      Units(iunit)%in_use = .true.
      name_len = len_trim(filename)
      Units(iunit)%filename = filename( max(1,name_len-15) : name_len )
      return

 10   write(6,*) "FILEMANAGER: Error opening file ",trim(filename)
      call stop_model('FILEMANAGER: FILE OPENING ERROR',255)
      end subroutine openunit

      subroutine closeunit( unit )
!@sum closeunit closes the file the file corresponding to unit <unit>
      implicit none
!@var unit - unit of the file to close
      integer, intent(in) :: unit

      if ( unit>MAXUNIT .or. unit<MINUNIT
     $     .or. .not. Units(unit)%in_use ) then
        write(6,*) "FILEMANAGER: attempt to close wrong unit: ",unit
        call stop_model("FILEMANAGER: attempt to close wrong unit",255)
      endif

      close( unit )
      Units(unit)%in_use = .false.
      Units(unit)%filename = " "
      end subroutine closeunit

      subroutine print_open_units
!@sum print_open_units prints info on open units (for debugging)
      implicit none
      integer unit

      write(6,*) "FILEMANAGER: Open Units:"
      do unit=MINUNIT,MAXUNIT
        if ( Units(unit)%in_use ) then
          write(6,*) "unit = ", unit, "file = ", Units(unit)%filename
        endif
      enddo
      end subroutine print_open_units

      SUBROUTINE OPENUNITS(FILENM,IUNIT,QBIN,NREQ)
!@sum  OPENUNITS sets unit number for requested files and opens them
!@auth Gavin Schmidt, simplified by I. Aleinov
!@ver  1.0
      IMPLICIT NONE
!@var IUNIT unit numbers for files in current request
      INTEGER, INTENT(OUT), DIMENSION(*) :: IUNIT
!@var FILENM name of file to open
      CHARACTER*(*), INTENT(IN), DIMENSION(*) :: FILENM
!@var QBIN true if binary file is to be opened (UNFORMATTED)
      LOGICAL, INTENT(IN), DIMENSION(*) :: QBIN
!@var NREQ number of file unit numbers requested
      INTEGER, INTENT(IN) :: NREQ
      INTEGER I !@var I loop variable

      DO I=1,NREQ
        call openunit( FILENM(I), IUNIT(I), QBIN(I) )
      END DO
      END SUBROUTINE OPENUNITS

      SUBROUTINE CLOSEUNITS( IUNIT, NREQ)
!@sum  CLOSEUNITS closes files corresponding to units IUNIT
!@auth Gavin Schmidt, I. Aleinov
!@ver  1.0
      IMPLICIT NONE
!@var IUNIT unit numbers for files in current request
      INTEGER, INTENT(IN), DIMENSION(*) :: IUNIT
!@var NREQ number of file unit numbers
      INTEGER, INTENT(IN) :: NREQ
      INTEGER I

      DO I=1,NREQ
        call closeunit( IUNIT(I) )
      END DO
      END SUBROUTINE CLOSEUNITS

      END MODULE FILEMANAGER

      SUBROUTINE DREAD (IUNIT,AIN,LENGTH,AOUT)
!@sum   DREAD   read in real*4 array and convert to real*8
!@auth  Original Development Team
!@ver   1.0
!@var NAME name of record being read
      USE FILEMANAGER, only : NAME=>nameunit
      IMPLICIT NONE
      INTEGER :: IUNIT                    !@var  IUNIT  file unit number
      INTEGER, INTENT(IN) :: LENGTH       !@var  LENGTH size of array
      REAL*4, INTENT(OUT) :: AIN(LENGTH)  !@var  AIN    real*4 array
      REAL*8, INTENT(OUT) :: AOUT(LENGTH) !@var  AOUT   real*8 array
      INTEGER :: N                        !@var  N      loop variable

      READ (IUNIT,ERR=910,END=920) AIN
C**** do transfer backwards in case AOUT and AIN are same workspace
      DO N=LENGTH,1,-1
        AOUT(N)=AIN(N)
      END DO
      WRITE(6,*) "Sucessful read from file ",NAME(IUNIT)
      RETURN
  910 WRITE(6,*) 'READ ERROR ON FILE ',TRIM(NAME(IUNIT))
      call stop_model('dREAD: READ ERROR',255)
  920 WRITE(6,*) 'END OF FILE ENCOUNTERED ON FILE ',TRIM(NAME(IUNIT))
      call stop_model('dREAD: No data found',255)
      RETURN
      END

      SUBROUTINE MREAD (IUNIT,M,NSKIP,AIN,LENGTH,AOUT)
!@sum   MREAD   read in integer and real*4 array and convert to real*8
!@auth  Original Development Team
!@ver   1.0
!@var NAME name of record being read
      USE FILEMANAGER, only : NAME=>nameunit
      IMPLICIT NONE
      INTEGER :: IUNIT                    !@var  IUNIT  file unit number
      INTEGER, INTENT(OUT) :: M           !@var  M      initial integer
      INTEGER, INTENT(IN) :: NSKIP        !@var  NSKIP  words to skip
      INTEGER, INTENT(IN) :: LENGTH       !@var  LENGTH size of array
      REAL*4, INTENT(OUT) :: AIN(LENGTH)  !@var  AIN    real*4 array
      REAL*8, INTENT(OUT) :: AOUT(LENGTH) !@var  AOUT   real*8 array
      REAL*4 :: X                         !@var  X      dummy variable
      INTEGER :: N                        !@var  N      loop variable

      READ (IUNIT,ERR=910,END=920) M,(X,N=1,NSKIP),AIN
C**** do transfer backwards in case AOUT and AIN are same workspace
      DO N=LENGTH,1,-1
        AOUT(N)=AIN(N)
      END DO
      WRITE(6,*) "Sucessful read from file ",NAME(IUNIT)
      RETURN
  910 WRITE(6,*) 'READ ERROR ON FILE ',NAME(IUNIT)
      call stop_model('mREAD: READ ERROR',255)
  920 WRITE(6,*) 'END OF FILE ENCOUNTERED ON FILE ',NAME(IUNIT)
      call stop_model('mREAD: No data found',255)
      RETURN
      END

      SUBROUTINE READT (IUNIT,NSKIP,AIN,LENGTH,AOUT,IPOS)
!@sum   READT  read in title and real*4 array and convert to real*8
!@auth  Original Development Team
!@ver   1.0
!@var NAME name of record being read
      USE FILEMANAGER, only : NAME=>nameunit
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IUNIT        !@var  IUNIT  file unit number
      INTEGER, INTENT(IN) :: NSKIP    !@var  NSKIP  no. of R*4's to skip
      INTEGER, INTENT(IN) :: LENGTH       !@var  LENGTH size of array
      INTEGER, INTENT(IN) :: IPOS  !@var  IPOS   no. of recs. to advance
      REAL*4, INTENT(OUT) :: AIN(LENGTH)  !@var  AIN    real*4 array
      REAL*8, INTENT(OUT) :: AOUT(LENGTH) !@var  AOUT   real*8 array
      REAL*4 :: X               !@var  X      dummy variable
      INTEGER :: N              !@var  N      loop variable
      CHARACTER*80 TITLE        !@var  TITLE  title of file record

      DO N=1,IPOS-1
        READ (IUNIT,END=920)
      END DO
      READ (IUNIT,ERR=910,END=920) TITLE,(X,N=1,NSKIP),AIN
C**** do transfer backwards in case AOUT and AIN are same workspace
      DO N=LENGTH,1,-1
        AOUT(N)=AIN(N)
      END DO
      WRITE(6,*) "Read from file ",TRIM(NAME(IUNIT)),": ",TRIM(TITLE)
      RETURN
  910 WRITE(6,*) 'READ ERROR ON FILE ',NAME(IUNIT)
      call stop_model('tREAD: READ ERROR',255)
  920 WRITE(6,*) 'END OF FILE ENCOUNTERED ON FILE ',NAME(IUNIT)
      call stop_model('tREAD: No data found',255)
      END

      subroutine WRITEI (iunit,it,aout,len4)
!@sum   WRITEI  writes array surrounded by IT and secures it
!@auth  Original Development Team
!@ver   1.0
!@var NAME name of record being read
      USE FILEMANAGER, only : NAME=>nameunit
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IUNIT       !@var  IUNIT  file unit number
      INTEGER, INTENT(IN) :: IT          !@var  IT time, 1st & last word
      INTEGER, INTENT(IN) :: LEN4        !@var  LENGTH size of array
      REAL*4,  INTENT(IN) :: AOUT(LEN4)  !@var  AOUT   real*4 array

      write (iunit) it,aout,it
      call sys_flush(iunit)
      write (6,*) "Wrote to file ",TRIM(NAME(IUNIT)),", time=",it
      return
      END subroutine WRITEI

      subroutine READI (iunit,it,ain,it1,len4,iok)
!@sum  READI reads array surrounded by IT (for post processing)
!@auth  Original Development Team
!@ver   1.0
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IUNIT,LEN4
      INTEGER, INTENT(out) :: IT,it1,iok ! iok: 0='ok',1='not ok'
      real*4  AIN(LEN4)
      iok = 0
      read(iunit,end=555) it,ain,it1
      return
  555 iok=1
      return
      end subroutine readi

      subroutine io_POS (iunit,it,len4,itdif)
!@sum   io_POS  positions a seq. output file for the next write operat'n
!@auth  Original Development Team
!@ver   1.0
!@var NAME name of record being read
      USE FILEMANAGER, only : NAME=>nameunit
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IUNIT !@var IUNIT  file unit number
      INTEGER, INTENT(IN) :: IT,ITdif !@var IT,ITdif current time,dt
      INTEGER, INTENT(IN) :: LEN4 !@var LENGTH of array in words
      INTEGER :: IT1,IT2   !@var  time_tags at start,end of each record
      INTEGER :: N              !@var  N      loop variable

      read (iunit,end=10,err=50) it1,(it2,n=1,len4+1)
      if(it.ge.it1) go to 30
   10 write(6,*) "Starting a new file ",TRIM(NAME(IUNIT)),", time=",it
      rewind iunit
      return

   20 read (iunit,end=40,err=50) it1,(it2,n=1,len4+1)
   30 if (it2 .ne. it1) then
        write(6,*) 'file ',TRIM(NAME(IUNIT)),' damaged: it/it1/it2=',
     *    it,it1,it2
        call stop_model('io_POS: damaged file',255)
      end if
      if (it .ge. it1+itdif) go to 20
      write (6,*) "positioned ",TRIM(NAME(IUNIT)),", it1/itime=",it1,it
      return
   40 write (6,*) "file ",TRIM(NAME(IUNIT))," too short, it1/it=",it1,it
      call stop_model('io_POS: file too short',255)
   50 write (6,*) "Read error on: ",TRIM(NAME(IUNIT)),", it1/it=",it1,it
      call stop_model('io_POS: read error',255)
      END subroutine io_POS

      SUBROUTINE CHECK3(A,IN,JN,LN,SUBR,FIELD)
!@sum  CHECK3 Checks for NaN/INF in real 3-D arrays
!@auth Original development team
!@ver  1.0
      IMPLICIT NONE

!@var IN,JN,LN size of 3-D array
      INTEGER, INTENT(IN) :: IN,JN,LN
!@var SUBR identifies where CHECK3 was called from
      CHARACTER*6, INTENT(IN) :: SUBR
!@var FIELD identifies the field being tested
      CHARACTER*6, INTENT(IN) :: FIELD
!@var A array being tested
      REAL*8, DIMENSION(IN,JN,LN),INTENT(IN) :: A
      LOGICAL :: QCHECK3 = .FALSE.
      INTEGER I,J,L !@var I,J,L loop variables

!$OMP PARALLEL DO PRIVATE (L,J,I) SHARED (QCHECK3)
      DO L=1,LN
      DO J=1,JN
      DO I=1,IN
        IF (.NOT.(A(I,J,L).GT.0..OR.A(I,J,L).LE.0.) .or.
     *       ABS(A(I,J,L)) .gt.HUGE(A(I,J,L)) ) THEN
          WRITE (6,*) TRIM(FIELD),': ',I,J,L,A(I,J,L),'after ',SUBR
          IF (J.LT.JN.AND.J.GT.1) QCHECK3 = .TRUE.
        END IF
      END DO
      END DO
      END DO
!$OMP END PARALLEL DO
      CALL SYS_FLUSH(6)
      IF (QCHECK3) call stop_model('CHECK3',255)
      RETURN
      END SUBROUTINE CHECK3

      function unit_string (pow10,ending)
!@sum Construct a units string with nice properties (no embedded blanks)
!@auth G. Schmidt, J. Lerner
C**** If a trailing ')' is supplied, it is assumed that a leading
C****      '(' is required, so it is inserted
      character*(*) ending,unit_string
      character*10 tpow
      integer pow10

      tpow = ' '
      if(pow10.ne.0) then
        write(tpow,'(i3)') pow10
        if (index(ending,')') .ne.0) then
          tpow='(10^'//trim(adjustl(tpow))
        else
          tpow= '10^'//trim(adjustl(tpow))
        end if
      endif
      unit_string = adjustl(trim(tpow)//" "//trim(ending))
      return
      end function unit_string

      subroutine stop_model( message, retcode )
!@sum Aborts the execution of the program. Passes an error message and
!@+ a return code to the calling script. Should be used instead of STOP
      USE PARAM
!@var message an error message (reason to stop)
      character*(*), intent (in) :: message
!@var retcode return code to be passed to the calling script
      integer, intent(in) :: retcode
!@dbparam dump_core if set to 1 dump core for debugging
      integer :: dump_core = 0
      integer, parameter :: iu_err = 9

c**** don't call sync_param if the error is in 'PARAM' to avoid loops
      if ( message(1:6) .ne. 'PARAM:' ) then
        call sync_param( "dump_core", dump_core )
      else
        write (6,*) " Error in PARAM: Can't use sync_param."
        write (6,*) " Will use default dump_core = ", dump_core
      endif

      write (6,'(//2(" ",132("*")/))')
      write (6,*) ' Program terminated due to the following reason:'
      write (6,*) ' >>  ', message, '  <<'
      write (6,'(/2(" ",132("*")/))')

      if ( retcode .ne. 12 .and. retcode .ne. 13 ) then
        open( iu_err, file='error_message',
     &       form='FORMATTED', status='REPLACE', ERR=10 )
        write ( iu_err, *, ERR=10 ) message
        close( iu_err )
      endif

      call sys_flush(6)

      if ( retcode > 13 .and. dump_core > 0 ) then
        call abort
      else
        call exit_rc ( retcode )
      endif

 10   continue
c**** something is terribly wrong, writing to stderr instead ...
      write( 0, * ) "Can't write to the error_message file"
      write( 0, * ) message
      call exit_rc ( retcode )
      end subroutine stop_model


module mod1
implicit none
private
public f1, f2, f3, f4, f2b, f3b, f5b

contains

integer function f1(a, b) result(r)
integer, intent(in) :: a, b
r = a + b
end function

integer function f2(n, a) result(r)
integer, intent(in) :: n, a(n)
r = sum(a)
end function

integer function f3(n, m, a) result(r)
integer, intent(in) :: n, m, a(n,m)
r = sum(a)
end function

integer function f2b(a) result(r)
integer, intent(in) :: a(:)
r = sum(a)
end function

integer function f3b(a) result(r)
integer, intent(in) :: a(:,:)
r = sum(a)
end function

integer function f4(a, b)
integer, intent(in) :: a
integer, intent(out) :: b
b = a
f4 = 0
end function

integer function f5b(a) result(r)
integer, intent(in) :: a(:,:)
integer :: i
r = 0
do i = 1, size(a, 2)
    r = r + a(1, i)
end do
end function

end module


! { dg-do compile }
! { dg-options "-fwhole-file" }
! Test the fix for the third problem in PR40011, where false
! type/rank mismatches were found in the main program calls.
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
!
subroutine test_d(fn, val, res)
  double precision fn
  double precision val, res

  print *, fn(val), res
end subroutine

subroutine test_c(fn, val, res)
  complex fn
  complex val, res

  print *, fn(val), res
end subroutine

program specifics

  intrinsic dcos
  intrinsic dcosh
  intrinsic dexp

  intrinsic conjg

  call test_d (dcos, 1d0, dcos(1d0))
  call test_d (dcosh, 1d0, dcosh(1d0))
  call test_d (dexp, 1d0, dexp(1d0))

  call test_c (conjg, (1.0,1.0) , conjg((1.0,1.0)))

end program


    program demo_hypot
    use, intrinsic :: iso_fortran_env, only : &
     & real_kinds, real32, real64, real128
    implicit none
    real(kind=real32) :: x, y
    real(kind=real32),allocatable :: xs(:), ys(:)
    integer :: i
    character(len=*),parameter :: f='(a,/,SP,*(3x,g0,1x,g0:,/))'

       x = 1.e0_real32
       y = 0.5e0_real32

       write(*,*)
       write(*,'(*(g0))')'point <',x,',',y,'> is ',hypot(x,y)
       write(*,'(*(g0))')'units away from the origin'
       write(*,*)

       ! elemental
       xs=[  x,  x**2,  x*10.0,  x*15.0, -x**2  ]
       ys=[  y,  y**2, -y*20.0,  y**2,   -y**2  ]

       write(*,f)"the points",(xs(i),ys(i),i=1,size(xs))
       write(*,f)"have distances from the origin of ",hypot(xs,ys)
       write(*,f)"the closest is",minval(hypot(xs,ys))

    end program demo_hypot


SUBROUTINE random_wave_signal_3D(i_spec, eta0, n_cut, beta, nt, nx, ny, beta0, x0, y0, x, y,   &
     dt, Tp, Hs, depth, grav, inc_wave_file, kh_max, seed, seed2, eta, phiS, time0 )
  !-----------------------------------------------------------------------
  !
  ! Generate a pseudo-random long crested wave with direction BETA0 to the
  ! x-axis, over NT time steps at NX by NY points over the computational
  ! free-surface.  The x-positions of the points in the wave generation
  ! zone are given by x(1:nx,1:ny) and y(1:nx,1:ny),
  ! and the time-step DT is uniform.  The water depth at the wavemaker (x0,y0)
  ! is DEPTH.  The wave can be based on a long-crested P-M (i_spec=30) or
  ! JONSWAP (ispec=31) spectrum at angle BETA0 to the x-axis, or it can be
  ! a JONSWAP with NORMAL directional spreading about the angle BETA0 (i_spec=33).
  ! The wave is moved around in space using linear theory in the frequency
  ! domain.  eta & phiS are returned with the time series
  ! of elevation and the potential at z=0 in the wavemaker zone.
  !
  ! When i_spec=-30, a mono-chromatic wave is generated with period Tp,
  ! height Hs and angle BETA0.
  !
  !
  ! By Harry B. Bingham
  !
  !----------------------------------------------------------------------
  IMPLICIT none
  CHARACTER(len=30) inc_wave_file, header
  integer, parameter :: long=selected_real_kind(12,99)
  integer i_spec, seed, seed2, nt, nx, ny, n_cut
  real(kind=long) :: Tp, Hs, dt, depth, time0, x0, y0, grav
  real(kind=long) :: x(nx,ny), y(nx,ny), phiS(nx,ny,nt), eta(nx,ny,nt), &
       eta0(nt), beta(nt)

  ! Local variables
  INTEGER :: i, j, k, ns_inc, ndat
  real(kind=long) :: factor, domega, realpt, beta0, dx,                  &
       imagpt, spec, phase, nu, coslnu, sinlnu, magx2, x2(3), x1(2),     &
       kinf, omega, dist, realarg, imagarg, reala, imaga,                &
       zero=0._long,  one=1._long, two=2._long, pi,twopi,udum=1.0_long,  &
       velfact, tanhkhi, dt_inc, dum, kh_max, phifact, kh, t, amp, deg2rad
  !
  ! Local workspace
  !
  real(kind=long),Allocatable :: work_eta(:), work_phi(:)
  allocate( work_eta(nt), work_phi(nt))
  !
  !
  ! Some parameters
  !
  pi=acos(-one)
  twopi=two*pi
  deg2rad=pi/180._long
  !
  IF(i_spec >= 0)THEN
     !
     ! Generate the random wave.
     !
     ! The FT factor.
     !
     factor = two/nt
     !
     ! The Fourier coefficients have been built based on SI dimensional numbers.  Omega is
     ! radian frequency.
     !
     domega = twopi / (nt * dt)
     !
     ! Translate these Fourier amplitudes around in space to generate the
     ! eta and phiS coefficients over this portion of the free-surface.
     !
     DO k=1,ny
        DO j = 1, nx
           !
           ! Take care of omega=0 and  the Nyquist frequency.
           !
           work_eta(1) = zero
           work_eta(2) = zero
           work_phi(1) = zero
           work_phi(2) = zero
           !
           ! The rest of frequency space.
           !
           DO i = 2, n_cut
              omega = (i - 1) * domega
              kinf = omega * omega / grav
              IF (depth.gt.zero) then
                 ! Calling this routine with udum=1. gives the SI dimensional wavenumber.
                 CALL fdwvnum (depth, omega, kinf, udum, grav, nu)
              ELSE
                 nu = kinf
              ENDIF
              !
              ! Compute the distance (dist) from the origin of the coordinates (x0) to
              ! the point where the wave elevation is to be obtained, measured along
              ! the direction of wave propogation.
              !
              x1 (1) = cos (deg2rad*beta(i))
              x1 (2) = sin (deg2rad*beta(i))
              x2 (1) = x(j,k)-x0
              x2 (2) = y(j,k)-y0
              !
              ! Beta is the angle between the (positive sense of the) incident wave
              ! vector and the (positive sense of the) (x,y) point vector.
              !
              dist = x1 (1) * x2 (1) + x1 (2) * x2 (2)
              !
              ! Multiply each Fourier coefficient
              ! by e^-i*nu*l to shift it to the point (x,y).  The coefficients are defined
              ! such that eta(t) = Re B(omega) e^(omega t - k theta).
              !
              if(nu*depth > 15.0)then
                 ! this wave component is in infinite depth (to double-precision).
                 velfact = omega
              else
                 ! this wave component is in finite depth.
                 tanhkhi = cosh(nu*depth)/sinh(nu*depth)
                 velfact = omega * tanhkhi
              end if
              phifact=grav/omega
              !
              coslnu = cos (nu * dist)
              sinlnu = sin (nu * dist)
              reala = eta0(2*i-1)
              imaga = eta0(2*i)
              realarg = (reala * coslnu - imaga * sinlnu)
              imagarg = (coslnu * imaga + sinlnu * reala)
              work_eta(2*i-1) = realarg
              work_eta(2*i) = imagarg
              !
              ! The surface velocity potential
              !
              work_phi(2*i-1) = phifact * imagarg
              work_phi(2*i) =  -phifact * realarg
           enddo
           do i=n_cut+1,nt/2
              work_eta(2*i-1)=zero
              work_eta(2*i) = zero
              work_phi(2*i-1) = zero
              work_phi(2*i) =  zero
           end do
           ! Inverse transform to get the time-series at this point (j,k).
           CALL drealft (work_eta, nt, -1)
           CALL drealft (work_phi, nt, -1)
           eta(j,k,:)=work_eta(:)
           phiS(j,k,:)=work_phi(:)
        enddo
     end DO
  ELSE
     !
     ! For the monochromatic case things are much simpler.
     !
     omega=twopi/Tp
     kinf=omega**2/grav;
     ! Get the wavenumber nu
     CALL fdwvnum(depth,omega,kinf,one,grav,nu)
     amp=Hs/two
     phifact=grav/omega
     !
     do i=1,nt
        t=time0+(i-1)*dt
        eta0(i)=amp*cos(-omega*t)
        do k=1,ny
           do j=1,nx
              x1 (1) = cos (deg2rad*beta0)
              x1 (2) = sin (deg2rad*beta0)
              x2 (1) = x(j,k)-x0
              x2 (2) = y(j,k)-y0
              !
              ! Beta0 is the angle between the (positive sense of the) incident wave
              ! vector and the (positive sense of the) (x,y) point vector.
              !
              dist = x1 (1) * x2 (1) + x1 (2) * x2 (2)
              eta(j,k,i)=amp*cos(nu*dist-omega*t)
              phiS(j,k,i)=phifact*amp*sin(nu*dist-omega*t)
           end do
        end do
     end do
     !
     !  Write the wavemaker signal.
     !
     open(21,file='eta0_irregular',status='unknown')
     write(21,36)Hs,Tp,depth,beta0
36      format('% Mono-chromatic wave with H=',e12.4,' T=',e12.4,' at h=',e12.4,  &
             ' at heading angle ',f10.2,'.')
     do i=1,nt
        write(21,*)(i-1)*dt,eta0(i)
     end do
     close(21)
  END IF

  DEALLOCATE(work_eta, work_phi)
444 FORMAT ()
445 FORMAT(3e12.5)
  RETURN
END SUBROUTINE random_wave_signal_3D


SUBROUTINE DiffYuniform3D(var,varY,order,DiffStencilArray,Nx,Ny,Nz,beta)
! By Allan P. Engsig-Karup.
!FIXME: this script has not been tested for bugs
USE Precision
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx, Ny, Nz, rank, order, beta, i,j, k
REAL(KIND=long), DIMENSION(2*beta+1,2*beta+1,2) :: DiffStencilArray
REAL(KIND=long), DIMENSION(Nz,Nx,Ny) :: var, varY
REAL(KIND=long), DIMENSION(2*beta+1) :: Stencil
rank = 2*beta+1
! one-sided
DO j = 1, beta
	Stencil = DiffStencilArray(1:rank,j,order)
	DO i = 1, Nx
		DO k = 1, Nz
			varY(k,i,j) = DOT_PRODUCT(Stencil,var(k,i,1:rank))
		END DO
	END DO
END DO
! centered
Stencil = DiffStencilArray(1:rank,beta+1,order)
DO i = 1, Nx
	DO j = beta+1, Ny-beta
		DO k = 1, Nz
			varY(k,i,j) = DOT_PRODUCT(Stencil,var(k,i,j-beta:j+beta))
		END DO
	END DO
END DO
! one-sided
DO j = Ny-beta+1, Ny
	Stencil = DiffStencilArray(1:rank,2*beta+1-(Ny-j),order)
	DO i = 1,Nx
		DO k = 1, Nz
			varY(k,i,j) = DOT_PRODUCT(Stencil,var(k,i,Ny+1-rank:Ny))
		END  DO
	END DO
END DO

END SUBROUTINE DiffYuniform3D


program somatorio2
implicit none

real :: cont
integer :: c

cont = 0
do c = 1,10
    cont = cont+(c**2)
end do

write(*,*) cont

end program somatorio2


c     # ------------------------------------------------------------
c     # Prescribes velocity fields for the unit square ([0.1]x[0,1]).
c     #
c     # Assumes all components are given in coordinates relative to
c     # the standard basis (1,0) and (0,1).
c     # ------------------------------------------------------------

      subroutine velocity_components(x,y,u)
      implicit none

      double precision x, y, u(2)
      double precision uderivs(4)

      double precision s

      call velocity_derivs(x,y,u,uderivs)

      end

      subroutine velocity_derivs(x,y,u,uderivs)
      implicit none

      double precision x, y, u(2)
      double precision uderivs(4)

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      double precision velocity(2)
      common /velocity_comm/ velocity

      double precision s, pim, u1x, u1y, u2x, u2y
      integer k

c     # uderivs(1) = u1x
c     # uderivs(2) = u1y
c     # uderivs(3) = u2x
c     # uderivs(4) = u2y

      u1x = 0
      u1y = 0
      u2x = 0
      u2y = 0

c     # Set non-zeros derivs only
      s = sqrt(2.d0)
      if (example .eq. 0) then
         u(1) = velocity(1)
         u(2) = velocity(2)
      elseif (example .eq. 1) then
c        # No sonic points, i.e. velocity field > 0
         u(1) = s*(cos(pi*x)**2 + 0.5d0)
         u(2) = s*(sin(pi*y)**2 + 0.5d0)
         u1x = -2*pi*s*cos(pi*x)*sin(pi*x)
         u2y =  2*pi*s*sin(pi*y)*cos(pi*y)
      elseif (example .eq. 2) then
c        # Velocity field crosses 0
         u(1) = s*(cos(pi*x)**2 - 0.5d0)
         u(2) = s*(sin(pi*y)**2 - 0.5d0)
         u1x = -2*pi*s*cos(pi*x)*sin(pi*x)
         u2y =  2*pi*s*sin(pi*y)*cos(pi*y)
      else
         write(6,'(A,A)') 'square_velocity : ',
     &              'No valid example provided'
         stop
      endif

      uderivs(1) = u1x
      uderivs(2) = u1y
      uderivs(3) = u2x
      uderivs(4) = u2y

      end

c     # ------------------------------------------------------------
c     # Center : u = u1*tau1 + u2*tau2   (div u might not be zero)
c     # ------------------------------------------------------------
      subroutine square_center_velocity(x,y,vel)
      implicit none

      double precision x,y,vel(3)

      double precision t1(3), t2(3)
      double precision t1inv(3), t2inv(3)
      double precision nvec(3), gradpsi(3), sv

      double precision p, px, py
      double precision u(2), uderivs(2)

      integer k

c     # Velocity components are given in Cartesian components
      call velocity_components(x,y,u)

c     # Velocities are all given in terms of Cartesian components
      do k = 1,2
        vel(k) = u(k)
      enddo
      vel(3) = 0

      end