! ============================================================================
!  File:        geoclaw_mod
! ============================================================================
!    Copyright (C) 2010-04-21 Clawpack Developers http://www.clawpack.org
!
!  Distributed under the terms of the Berkeley Software Distribution (BSD)
!  license
!                     http://www.opensource.org/licenses/
! ============================================================================

module geoclaw_module

    implicit none
    save

    logical, private :: module_setup = .false.

    ! ========================================================================
    !  Constants
    ! ========================================================================
    integer, parameter :: GEO_PARM_UNIT = 78
    integer, parameter :: KAPPA_UNIT = 42
    real(kind=8), parameter :: pi = 4.d0*datan(1.d0)
    real(kind=8), parameter :: DEG2RAD = pi / 180.d0
    real(kind=8), parameter :: RAD2DEG = 180.d0 / pi

    ! ========================================================================
    !  Physics
    ! ========================================================================
    real(kind=8) :: grav, rho_air, ambient_pressure, earth_radius, sea_level
    ! Water density can be an array to handle multiple layers
    real(kind=8), allocatable :: rho(:)
    integer :: coordinate_system

    ! Rotational velocity of Earth
    real(kind=8), parameter :: omega = 2.0d0 * pi / 86164.2d0

    ! Forcing
    logical :: coriolis_forcing ! True then coriolis terms included in src
    real(kind=8) :: theta_0 ! Used if using the beta-plane approximation
    logical :: friction_forcing ! Friction forcing will be applied
    real(kind=8), dimension(:),allocatable :: manning_coefficient, manning_break
    integer :: num_manning
    real(kind=8) :: friction_depth

    ! Method parameters
    real(kind=8) :: dry_tolerance

contains

    ! ========================================================================
    !  set_geo(fname)
    ! ========================================================================
    !  Reads in user parameters from the given file name if provided
    ! ========================================================================
    subroutine set_geo(file_name)

        use utility_module, only: get_value_count

        use amr_module, only: mcapa, rinfinity

        implicit none

        ! Input
        character(len=*), intent(in), optional :: file_name

        ! Locals
        integer, parameter :: unit = 127

        integer :: i
        character(len=128) :: line

        if (.not.module_setup) then
            open(unit=GEO_PARM_UNIT,file='fort.geo',status="unknown",action="write")

            write(GEO_PARM_UNIT,*) ' '
            write(GEO_PARM_UNIT,*) '--------------------------------------------'
            write(GEO_PARM_UNIT,*) 'Physics Parameters:'
            write(GEO_PARM_UNIT,*) '-------------------'

            ! Read user parameters from setgeo.data
            if (present(file_name)) then
                call opendatafile(unit, file_name)
            else
                call opendatafile(unit, 'geoclaw.data')
            endif

            read(unit,*) grav
            read(unit,'(a)') line
            allocate(rho(get_value_count(line)))
            read(line,*) (rho(i), i=1, size(rho, 1))
            read(unit,*) rho_air
            read(unit,*) ambient_pressure
            read(unit,*) earth_radius
            read(unit,*) coordinate_system
            read(unit,*) sea_level
            read(unit,*)
            read(unit,*) coriolis_forcing
            if (coordinate_system == 1 .and. coriolis_forcing) then
                read(unit,*) theta_0
            else
                theta_0 = 0.d0
            endif
            read(unit,*) friction_forcing
            if (friction_forcing) then
                read(unit,*) num_manning
                allocate(manning_coefficient(num_manning))
                allocate(manning_break(num_manning))
                manning_break(num_manning) = rinfinity
                read(unit,*) manning_coefficient(:)
                read(unit,*) manning_break(1:num_manning-1)
                read(unit,*) friction_depth
            else
                friction_depth = rinfinity
            endif
            read(unit,*)
            read(unit,*) dry_tolerance

            close(unit)

            ! coordinate_system = 1 means Cartesian grid in meters
            ! coordinate_system = 2 means lat-long grid on sphere
            ! Check that coordinate_system is consistent with mcapa:
            if ((coordinate_system > 1) .and. (mcapa == 0)) then
                print *, 'ERROR in setgeo:  if coordinate_system > 1 then'
                print *, '      mcapa should be nonzero'
                stop
            endif
            if ((coordinate_system == 1) .and. (mcapa > 0)) then
                print *, 'ERROR in setgeo:  if coordinate_system = 1 then'
                print *, '      mcapa should be zero'
                stop
            endif

            write(GEO_PARM_UNIT,*) '   gravity:',grav
            write(GEO_PARM_UNIT,*) '   density water:',rho
            write(GEO_PARM_UNIT,*) '   density air:',rho_air
            write(GEO_PARM_UNIT,*) '   ambient pressure:',ambient_pressure
            write(GEO_PARM_UNIT,*) '   earth_radius:',earth_radius
            write(GEO_PARM_UNIT,*) '   coordinate_system:',coordinate_system
            write(GEO_PARM_UNIT,*) '   sea_level:',sea_level
            write(GEO_PARM_UNIT,*) ' '
            write(GEO_PARM_UNIT,*) '   coriolis_forcing:',coriolis_forcing
            write(GEO_PARM_UNIT,*) '   theta_0:',theta_0
            write(GEO_PARM_UNIT,*) '   friction_forcing:',friction_forcing
            if (friction_forcing) then
                write(GEO_PARM_UNIT,*) '   manning_coefficient:', manning_coefficient
                write(GEO_PARM_UNIT,*) '   friction_depth:',friction_depth
            else
                write(GEO_PARM_UNIT,*) '   manning_coefficient: not used'
                write(GEO_PARM_UNIT,*) '   friction_depth: not used'
            end if

            write(GEO_PARM_UNIT,*) ' '
            write(GEO_PARM_UNIT,*) '   dry_tolerance:', dry_tolerance

            module_setup = .true.
        end if

    end subroutine set_geo

    ! ==========================================================================
    !  Calculate the coriolis constant f
    !   If coordinate_system == 1 then
    !       A beta-plane approximation is used and y should be in meters
    !   if coordinate_system == 2 then
    !       Grid is in lat-long and y should be in degrees which is converted
    !       to radians
    ! ==========================================================================
    real(kind=8) pure function coriolis(y)

        implicit none

        ! Input
        real(kind=8), intent(in) :: y

        ! Locals
        real(kind=8) :: theta

        ! Assume beta plane approximation and y is in meters
        if (coordinate_system == 1) then
            theta = y / 111d3 * DEG2RAD + theta_0
            coriolis = 2.d0 * omega * (sin(theta_0) + (theta - theta_0)     &
                                                    * cos(theta_0))
        else if (coordinate_system == 2) then
            coriolis = 2.d0 * omega * sin(y * DEG2RAD)
        else
            ! Unknown coordinate system, return nothing
            coriolis = 0.d0
        endif
    end function coriolis

    ! ==========================================================================
    !  Calculate the distance along a sphere
    !    real(kind=8) spherical_distance(x1,y1,x2,y2)
    !       x1 = (long,lat)
    !       x2 = (long,lat)
    ! ==========================================================================
    real(kind=8) pure function spherical_distance(x1,y1,x2,y2) result(distance)

        implicit none

        ! Input
        real(kind=8), intent(in) :: x1,y1,x2,y2

        ! Locals
        real(kind=8) :: dx ,dy

        dx = (x2 - x1) * DEG2RAD
        dy = (y2 - y1) * DEG2RAD

        distance = earth_radius * 2.d0 * asin(sqrt(sin(0.5d0*dy)**2 &
                                   + cos(y1 * DEG2RAD)*cos(y2 * DEG2RAD) &
                                   * sin(0.5d0*dx)**2))

    end function spherical_distance

    !=================================================================
    ! Transform long,lat --> (x,y) coordinates.
    !
    ! On input:
    !    coords(2) = (longitude (E/W),latitude (N/S))
    !    projection_center(2) = (longitude (E/W),latitude (N/S)) - coordinates
    !                        where projection is true
    !
    ! On output:
    !    x(2)          (meters)
    !=================================================================
    pure function latlon2xy(coords,projection_center) result(x)

        real(kind=8), intent(in) :: coords(2), projection_center(2)
        real(kind=8) :: x(2)

        x(1) = deg2rad * earth_radius * (coords(1) - &
                    projection_center(1)) * cos(deg2rad * projection_center(2))
        x(2) = deg2rad * earth_radius * coords(2)

    end function latlon2xy

    !=================================================================
    ! Transform (x,y) --> (lat,lon) coordinates.
    !
    ! On input:
    !    x(2) = (meters)
    !    projection_center(2) = (longitude (E/W),latitude (N/S)) - coordinates
    !                        where projection is true
    !
    ! On output:
    !    coords(2) = (longitude,latitude)
    !=================================================================
    pure function xy2latlon(x,projection_center) result(coords)

        real(kind=8), intent(in) :: x(2), projection_center(2)
        real(kind=8) :: coords(2)

        coords(1) = projection_center(1) + x(1) &
                / (deg2rad * earth_radius * cos(deg2rad * projection_center(2)))
        coords(2) = x(2) / (deg2rad * earth_radius)
    end function xy2latlon

end module geoclaw_module


subroutine arakawa_jacobian(im, jm, dx, dy, a_bc, b_bc, Jacobian)

! Computes Jacobian J(a,b) in advective form
! See Arakawa (1966) J. Comp. Phys. vol 1, 119-143
! ** Note: Input fields must be "framed" with boundary conds.
!          Jacobian computed in internal points only.

implicit none

integer, intent(in)                           :: im, jm
real,    intent(in)                           :: dx, dy
real,    intent(in), dimension(0:im+1,0:jm+1) :: a_bc,b_bc

real, intent(out), dimension(im,jm) :: Jacobian

! Local variables:
integer :: i,j
real, dimension(im,jm) :: p1,p2,p3,p4,p5,p6,p7,p8
real, dimension(im,jm) :: q1,q2,q3,q4,q5,q6,q7,q8

!   6 --- 2 --- 5
!   |     |     |
!   |     |     |
!   3 --- 0 --- 1
!   |     |     |
!   |     |     |
!   7 --- 4 --- 8

i= 1 ; j= 0 ; p1 = a_bc(1+i:im+i,1+j:jm+j)
i= 0 ; j= 1 ; p2 = a_bc(1+i:im+i,1+j:jm+j)
i=-1 ; j= 0 ; p3 = a_bc(1+i:im+i,1+j:jm+j)
i= 0 ; j=-1 ; p4 = a_bc(1+i:im+i,1+j:jm+j)
i= 1 ; j= 1 ; p5 = a_bc(1+i:im+i,1+j:jm+j)
i=-1 ; j= 1 ; p6 = a_bc(1+i:im+i,1+j:jm+j)
i=-1 ; j=-1 ; p7 = a_bc(1+i:im+i,1+j:jm+j)
i= 1 ; j=-1 ; p8 = a_bc(1+i:im+i,1+j:jm+j)

i= 1 ; j= 0 ; q1 = b_bc(1+i:im+i,1+j:jm+j)
i= 0 ; j= 1 ; q2 = b_bc(1+i:im+i,1+j:jm+j)
i=-1 ; j= 0 ; q3 = b_bc(1+i:im+i,1+j:jm+j)
i= 0 ; j=-1 ; q4 = b_bc(1+i:im+i,1+j:jm+j)
i= 1 ; j= 1 ; q5 = b_bc(1+i:im+i,1+j:jm+j)
i=-1 ; j= 1 ; q6 = b_bc(1+i:im+i,1+j:jm+j)
i=-1 ; j=-1 ; q7 = b_bc(1+i:im+i,1+j:jm+j)
i= 1 ; j=-1 ; q8 = b_bc(1+i:im+i,1+j:jm+j)

Jacobian = (p1-p3)*(q2-q4) - (p2-p4)*(q1-q3)  +                & ! J++
           q2*(p5-p6) - q4*(p8-p7) - q1*(p5-p8) + q3*(p6-p7) + & ! Jx+
           p1*(q5-q8) - p3*(q6-q7) - p2*(q5-q6) + p4*(q8-q7)     ! J+x

Jacobian = Jacobian/12./dx/dy

end subroutine arakawa_jacobian
!------------------------------------------------------------------------
subroutine v2vcosphii(jm, km, cosphi, V, Vcosphii)

!
implicit none

! In
integer, intent(in)                 :: jm,km
real, intent(in),  dimension(jm,km) :: cosphi,V

! Out
real, intent(out), dimension(0:jm,km) :: Vcosphii

! Local
integer :: j

! Interpolate Vcosphi onto cell boundaries
Vcosphii=0.
do j=1,jm-1
  Vcosphii(j,:) = ( V(j,:)*cosphi(j,:) + V(j+1,:)*cosphi(j+1,:) )/2.
enddo

end subroutine v2vcosphii
!------------------------------------------------------------------------
subroutine vcosphii2wi(jm, km, a, dphi, dp, cosphi, Vcosphii, Wi)

!
implicit none

! In
integer, intent(in)                  :: jm,km
real, intent(in)                     :: a,dphi,dp
real, intent(in), dimension(jm,km)   :: cosphi
real, intent(in), dimension(0:jm,km) :: Vcosphii

! Out
real, intent(out), dimension(jm,0:km) :: Wi

! Local
integer :: j,k
real :: rdy
real, dimension(jm,km)      :: Vcosphi_y

rdy=1./dphi/a

! Integrate continuity eqn from top down to get W
Vcosphi_y = ( Vcosphii(1:jm,:) - Vcosphii(0:jm-1,:) )/cosphi*rdy
Wi=0.
do k=1,km-1
  Wi(:,k) = Wi(:,k-1) - Vcosphi_y(:,k)*dp
enddo

end subroutine vcosphii2wi
!------------------------------------------------------------------------
subroutine upwind(jm, km, a, dphi, dp, cosphi, Vcosphii, Wi, q, Vq_y, Wq_p)

! Compute upwind-differenced moisture flux divergence

implicit none

! In
integer, intent(in)                      :: jm,km
real, intent(in)                         :: a,dphi,dp
real, intent(in),  dimension(0:jm,   km) :: Vcosphii
real, intent(in),  dimension(  jm, 0:km) :: Wi
real, intent(in),  dimension(  jm,   km) :: q, cosphi

! Out
real, intent(out), dimension(jm,km) :: Vq_y,Wq_p

! Local
integer :: j,k,iy,iz
real :: rdp, rdy
real, dimension(0:jm,  km)  :: Vq
real, dimension(  jm,0:km)  :: Wq

rdy=1./dphi/a
rdp=1./dp

! Horizontal flux divergence
Vq=0.
do k=1,km
 do j=1,jm-1
    iy = ( 1-nint(sign(1.,Vcosphii(j,k))) )/2 ! V >= 0 => iy=0; V < 0 => iy=1
    Vq(j,k) = Vcosphii(j,k)*q(j+iy,k)
 enddo
enddo
Vq_y = ( Vq(1:jm,:) - Vq(0:jm-1,:) )/cosphi*rdy

! Vertical flux divergence
Wq=0.
do j=1,jm
 do k=1,km-1
 iz = ( 1-nint(sign(1.,Wi(j,k))) )/2    ! W >= 0 => iz=0; W < 0 => iz=1
 Wq(j,k) = Wi(j,k)*q(j,k+iz)
 enddo
enddo
Wq_p = ( Wq(:,1:km) - Wq(:,0:km-1) )*rdp

end subroutine upwind
!------------------------------------------------------------------------
subroutine smolar(jm, km, a, dphi, dp, dt, cosphi, Vcosphii, Wi, q, qdot)

! Low-diffusivity upwind advection scheme
! Ref: Smolarkiewicz, Mon Wea Rev (1983) p.479-486

implicit none

! In
integer, intent(in)                      :: jm,km
real, intent(in)                         :: a,dphi,dp,dt
real, intent(in),  dimension(0:jm,   km) :: Vcosphii
real, intent(in),  dimension(  jm, 0:km) :: Wi
real, intent(in),  dimension(  jm,   km) :: q, cosphi

! Out
real, intent(out), dimension(jm,km) :: qdot

! Local
integer :: j,k,iy,iz
real :: rdp, rdy,qmin,Sc,tdt
real, dimension(0:jm,  km) :: Vtilde
real, dimension(  jm,0:km) :: Wtilde
real, dimension(  jm,  km) :: qstar,vq_y,wq_p,q1

rdy = 1./dphi/a
rdp = 1./dp
tdt = 2.*dt
Sc  = 1.08

! Scheme works only for positive definite fields,
! so add uniform background field to ensure q >= 0
q1 = q-minval(q)

! compute conventional upwind tendency
call upwind(jm, km, a, dphi, dp, cosphi, Vcosphii, Wi, q1, vq_y, wq_p)

! initial forecast
qstar = q1 - (vq_y + wq_p)*tdt

! compute "diffusive" velocities
Vtilde = 0.
do j=1,jm-1
   Vtilde(j,:) = Sc*( abs(Vcosphii(j,:))*a*dphi - tdt*Vcosphii(j,:)**2 )* &
           ( qstar(j+1,:)-qstar(j,:) )/( qstar(j+1,:)+qstar(j,:)+1.e-15 )*rdy
enddo
Wtilde = 0.
do k=1,km-1
   Wtilde(:,k) = Sc*( abs(Wi(:,k))*dp - tdt*Wi(:,k)**2 )* &
           ( qstar(:,k+1)-qstar(:,k) )/( qstar(:,k+1)+qstar(:,k)+1.e-15 )*rdp
enddo

! compute advection by diffusive velocities
call upwind(jm, km, a, dphi, dp, cosphi, Vtilde, Wtilde, qstar, vq_y, wq_p)

! add correction to tendency
qdot = (qstar - q1)/tdt - (vq_y + wq_p)

end subroutine smolar


*> \brief \b CLANHF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLANHF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK )
*
*       .. Scalar Arguments ..
*       CHARACTER          NORM, TRANSR, UPLO
*       INTEGER            N
*       ..
*       .. Array Arguments ..
*       REAL               WORK( 0: * )
*       COMPLEX            A( 0: * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CLANHF  returns the value of the one norm,  or the Frobenius norm, or
*> the  infinity norm,  or the  element of  largest absolute value  of a
*> complex Hermitian matrix A in RFP format.
*> \endverbatim
*>
*> \return CLANHF
*> \verbatim
*>
*>    CLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*>             (
*>             ( norm1(A),         NORM = '1', 'O' or 'o'
*>             (
*>             ( normI(A),         NORM = 'I' or 'i'
*>             (
*>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
*>
*> where  norm1  denotes the  one norm of a matrix (maximum column sum),
*> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
*> normF  denotes the  Frobenius norm of a matrix (square root of sum of
*> squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NORM
*> \verbatim
*>          NORM is CHARACTER
*>            Specifies the value to be returned in CLANHF as described
*>            above.
*> \endverbatim
*>
*> \param[in] TRANSR
*> \verbatim
*>          TRANSR is CHARACTER
*>            Specifies whether the RFP format of A is normal or
*>            conjugate-transposed format.
*>            = 'N':  RFP format is Normal
*>            = 'C':  RFP format is Conjugate-transposed
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER
*>            On entry, UPLO specifies whether the RFP matrix A came from
*>            an upper or lower triangular matrix as follows:
*>
*>            UPLO = 'U' or 'u' RFP A came from an upper triangular
*>            matrix
*>
*>            UPLO = 'L' or 'l' RFP A came from a  lower triangular
*>            matrix
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>            The order of the matrix A.  N >= 0.  When N = 0, CLANHF is
*>            set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension ( N*(N+1)/2 );
*>            On entry, the matrix A in RFP Format.
*>            RFP Format is described by TRANSR, UPLO and N as follows:
*>            If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
*>            K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
*>            TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A
*>            as defined when TRANSR = 'N'. The contents of RFP A are
*>            defined by UPLO as follows: If UPLO = 'U' the RFP A
*>            contains the ( N*(N+1)/2 ) elements of upper packed A
*>            either in normal or conjugate-transpose Format. If
*>            UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements
*>            of lower packed A either in normal or conjugate-transpose
*>            Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When
*>            TRANSR is 'N' the LDA is N+1 when N is even and is N when
*>            is odd. See the Note below for more details.
*>            Unchanged on exit.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (LWORK),
*>            where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*>            WORK is not referenced.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  We first consider Standard Packed Format when N is even.
*>  We give an example where N = 6.
*>
*>      AP is Upper             AP is Lower
*>
*>   00 01 02 03 04 05       00
*>      11 12 13 14 15       10 11
*>         22 23 24 25       20 21 22
*>            33 34 35       30 31 32 33
*>               44 45       40 41 42 43 44
*>                  55       50 51 52 53 54 55
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
*>  conjugate-transpose of the first three columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
*>  conjugate-transpose of the last three columns of AP lower.
*>  To denote conjugate we place -- above the element. This covers the
*>  case N even and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>                                -- -- --
*>        03 04 05                33 43 53
*>                                   -- --
*>        13 14 15                00 44 54
*>                                      --
*>        23 24 25                10 11 55
*>
*>        33 34 35                20 21 22
*>        --
*>        00 44 45                30 31 32
*>        -- --
*>        01 11 55                40 41 42
*>        -- -- --
*>        02 12 22                50 51 52
*>
*>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
*>  transpose of RFP A above. One therefore gets:
*>
*>
*>           RFP A                   RFP A
*>
*>     -- -- -- --                -- -- -- -- -- --
*>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
*>     -- -- -- -- --                -- -- -- -- --
*>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
*>     -- -- -- -- -- --                -- -- -- --
*>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
*>
*>
*>  We next  consider Standard Packed Format when N is odd.
*>  We give an example where N = 5.
*>
*>     AP is Upper                 AP is Lower
*>
*>   00 01 02 03 04              00
*>      11 12 13 14              10 11
*>         22 23 24              20 21 22
*>            33 34              30 31 32 33
*>               44              40 41 42 43 44
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
*>  conjugate-transpose of the first two   columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
*>  conjugate-transpose of the last two   columns of AP lower.
*>  To denote conjugate we place -- above the element. This covers the
*>  case N odd  and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>                                   -- --
*>        02 03 04                00 33 43
*>                                      --
*>        12 13 14                10 11 44
*>
*>        22 23 24                20 21 22
*>        --
*>        00 33 34                30 31 32
*>        -- --
*>        01 11 44                40 41 42
*>
*>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
*>  transpose of RFP A above. One therefore gets:
*>
*>
*>           RFP A                   RFP A
*>
*>     -- -- --                   -- -- -- -- -- --
*>     02 12 22 00 01             00 10 20 30 40 50
*>     -- -- -- --                   -- -- -- -- --
*>     03 13 23 33 11             33 11 21 31 41 51
*>     -- -- -- -- --                   -- -- -- --
*>     04 14 24 34 44             43 44 22 32 42 52
*> \endverbatim
*>
*  =====================================================================
      REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          NORM, TRANSR, UPLO
      INTEGER            N
*     ..
*     .. Array Arguments ..
      REAL               WORK( 0: * )
      COMPLEX            A( 0: * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, IFM, ILU, NOE, N1, K, L, LDA
      REAL               SCALE, S, VALUE, AA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      EXTERNAL           LSAME, ISAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLASSQ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, REAL, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
      IF( N.EQ.0 ) THEN
         CLANHF = ZERO
         RETURN
      ELSE IF( N.EQ.1 ) THEN
         CLANHF = ABS( A(0) )
         RETURN
      END IF
*
*     set noe = 1 if n is odd. if n is even set noe=0
*
      NOE = 1
      IF( MOD( N, 2 ).EQ.0 )
     $   NOE = 0
*
*     set ifm = 0 when form='C' or 'c' and 1 otherwise
*
      IFM = 1
      IF( LSAME( TRANSR, 'C' ) )
     $   IFM = 0
*
*     set ilu = 0 when uplo='U or 'u' and 1 otherwise
*
      ILU = 1
      IF( LSAME( UPLO, 'U' ) )
     $   ILU = 0
*
*     set lda = (n+1)/2 when ifm = 0
*     set lda = n when ifm = 1 and noe = 1
*     set lda = n+1 when ifm = 1 and noe = 0
*
      IF( IFM.EQ.1 ) THEN
         IF( NOE.EQ.1 ) THEN
            LDA = N
         ELSE
*           noe=0
            LDA = N + 1
         END IF
      ELSE
*        ifm=0
         LDA = ( N+1 ) / 2
      END IF
*
      IF( LSAME( NORM, 'M' ) ) THEN
*
*       Find max(abs(A(i,j))).
*
         K = ( N+1 ) / 2
         VALUE = ZERO
         IF( NOE.EQ.1 ) THEN
*           n is odd & n = k + k - 1
            IF( IFM.EQ.1 ) THEN
*              A is n by k
               IF( ILU.EQ.1 ) THEN
*                 uplo ='L'
                  J = 0
*                 -> L(0,0)
                  VALUE = MAX( VALUE, ABS( REAL( A( J+J*LDA ) ) ) )
                  DO I = 1, N - 1
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  DO J = 1, K - 1
                     DO I = 0, J - 2
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = J - 1
*                    L(k+j,k+j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = J
*                    -> L(j,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = J + 1, N - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
               ELSE
*                 uplo = 'U'
                  DO J = 0, K - 2
                     DO I = 0, K + J - 2
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = K + J - 1
*                    -> U(i,i)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = I + 1
*                    =k+j; i -> U(j,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = K + J + 1, N - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
                  DO I = 0, N - 2
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
*                    j=k-1
                  END DO
*                 i=n-1 -> U(n-1,n-1)
                  VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
               END IF
            ELSE
*              xpose case; A is k by n
               IF( ILU.EQ.1 ) THEN
*                 uplo ='L'
                  DO J = 0, K - 2
                     DO I = 0, J - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = J
*                    L(i,i)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = J + 1
*                    L(j+k,j+k)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = J + 2, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
                  J = K - 1
                  DO I = 0, K - 2
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  I = K - 1
*                 -> L(i,i) is at A(i,j)
                  VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                  DO J = K, N - 1
                     DO I = 0, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
               ELSE
*                 uplo = 'U'
                  DO J = 0, K - 2
                     DO I = 0, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
                  J = K - 1
*                 -> U(j,j) is at A(0,j)
                  VALUE = MAX( VALUE, ABS( REAL( A( 0+J*LDA ) ) ) )
                  DO I = 1, K - 1
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  DO J = K, N - 1
                     DO I = 0, J - K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = J - K
*                    -> U(i,i) at A(i,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = J - K + 1
*                    U(j,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = J - K + 2, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
               END IF
            END IF
         ELSE
*           n is even & k = n/2
            IF( IFM.EQ.1 ) THEN
*              A is n+1 by k
               IF( ILU.EQ.1 ) THEN
*                 uplo ='L'
                  J = 0
*                 -> L(k,k) & j=1 -> L(0,0)
                  VALUE = MAX( VALUE, ABS( REAL( A( J+J*LDA ) ) ) )
                  VALUE = MAX( VALUE, ABS( REAL( A( J+1+J*LDA ) ) ) )
                  DO I = 2, N
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  DO J = 1, K - 1
                     DO I = 0, J - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = J
*                    L(k+j,k+j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = J + 1
*                    -> L(j,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = J + 2, N
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
               ELSE
*                 uplo = 'U'
                  DO J = 0, K - 2
                     DO I = 0, K + J - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = K + J
*                    -> U(i,i)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = I + 1
*                    =k+j+1; i -> U(j,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = K + J + 2, N
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
                  DO I = 0, N - 2
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
*                    j=k-1
                  END DO
*                 i=n-1 -> U(n-1,n-1)
                  VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                  I = N
*                 -> U(k-1,k-1)
                  VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
               END IF
            ELSE
*              xpose case; A is k by n+1
               IF( ILU.EQ.1 ) THEN
*                 uplo ='L'
                  J = 0
*                 -> L(k,k) at A(0,0)
                  VALUE = MAX( VALUE, ABS( REAL( A( J+J*LDA ) ) ) )
                  DO I = 1, K - 1
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  DO J = 1, K - 1
                     DO I = 0, J - 2
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = J - 1
*                    L(i,i)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = J
*                    L(j+k,j+k)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = J + 1, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
                  J = K
                  DO I = 0, K - 2
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  I = K - 1
*                 -> L(i,i) is at A(i,j)
                  VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                  DO J = K + 1, N
                     DO I = 0, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
               ELSE
*                 uplo = 'U'
                  DO J = 0, K - 1
                     DO I = 0, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
                  J = K
*                 -> U(j,j) is at A(0,j)
                  VALUE = MAX( VALUE, ABS( REAL( A( 0+J*LDA ) ) ) )
                  DO I = 1, K - 1
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  DO J = K + 1, N - 1
                     DO I = 0, J - K - 2
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                     I = J - K - 1
*                    -> U(i,i) at A(i,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     I = J - K
*                    U(j,j)
                     VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
                     DO I = J - K + 1, K - 1
                        VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                     END DO
                  END DO
                  J = N
                  DO I = 0, K - 2
                     VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) )
                  END DO
                  I = K - 1
*                 U(k,k) at A(i,j)
                  VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) )
               END IF
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
     $         ( NORM.EQ.'1' ) ) THEN
*
*       Find normI(A) ( = norm1(A), since A is Hermitian).
*
         IF( IFM.EQ.1 ) THEN
*           A is 'N'
            K = N / 2
            IF( NOE.EQ.1 ) THEN
*              n is odd & A is n by (n+1)/2
               IF( ILU.EQ.0 ) THEN
*                 uplo = 'U'
                  DO I = 0, K - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K
                     S = ZERO
                     DO I = 0, K + J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(i,j+k)
                        S = S + AA
                        WORK( I ) = WORK( I ) + AA
                     END DO
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    -> A(j+k,j+k)
                     WORK( J+K ) = S + AA
                     IF( I.EQ.K+K )
     $                  GO TO 10
                     I = I + 1
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    -> A(j,j)
                     WORK( J ) = WORK( J ) + AA
                     S = ZERO
                     DO L = J + 1, K - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
   10             CONTINUE
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               ELSE
*                 ilu = 1 & uplo = 'L'
                  K = K + 1
*                 k=(n+1)/2 for n odd and ilu=1
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = K - 1, 0, -1
                     S = ZERO
                     DO I = 0, J - 2
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(j+k,i+k)
                        S = S + AA
                        WORK( I+K ) = WORK( I+K ) + AA
                     END DO
                     IF( J.GT.0 ) THEN
                        AA = ABS( REAL( A( I+J*LDA ) ) )
*                       -> A(j+k,j+k)
                        S = S + AA
                        WORK( I+K ) = WORK( I+K ) + S
*                       i=j
                        I = I + 1
                     END IF
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    -> A(j,j)
                     WORK( J ) = AA
                     S = ZERO
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               END IF
            ELSE
*              n is even & A is n+1 by k = n/2
               IF( ILU.EQ.0 ) THEN
*                 uplo = 'U'
                  DO I = 0, K - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K - 1
                     S = ZERO
                     DO I = 0, K + J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(i,j+k)
                        S = S + AA
                        WORK( I ) = WORK( I ) + AA
                     END DO
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    -> A(j+k,j+k)
                     WORK( J+K ) = S + AA
                     I = I + 1
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    -> A(j,j)
                     WORK( J ) = WORK( J ) + AA
                     S = ZERO
                     DO L = J + 1, K - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               ELSE
*                 ilu = 1 & uplo = 'L'
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = K - 1, 0, -1
                     S = ZERO
                     DO I = 0, J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(j+k,i+k)
                        S = S + AA
                        WORK( I+K ) = WORK( I+K ) + AA
                     END DO
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    -> A(j+k,j+k)
                     S = S + AA
                     WORK( I+K ) = WORK( I+K ) + S
*                    i=j
                     I = I + 1
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    -> A(j,j)
                     WORK( J ) = AA
                     S = ZERO
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       -> A(l,j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               END IF
            END IF
         ELSE
*           ifm=0
            K = N / 2
            IF( NOE.EQ.1 ) THEN
*              n is odd & A is (n+1)/2 by n
               IF( ILU.EQ.0 ) THEN
*                 uplo = 'U'
                  N1 = K
*                 n/2
                  K = K + 1
*                 k is the row size and lda
                  DO I = N1, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, N1 - 1
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,n1+i)
                        WORK( I+N1 ) = WORK( I+N1 ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = S
                  END DO
*                 j=n1=k-1 is special
                  S = ABS( REAL( A( 0+J*LDA ) ) )
*                 A(k-1,k-1)
                  DO I = 1, K - 1
                     AA = ABS( A( I+J*LDA ) )
*                    A(k-1,i+n1)
                     WORK( I+N1 ) = WORK( I+N1 ) + AA
                     S = S + AA
                  END DO
                  WORK( J ) = WORK( J ) + S
                  DO J = K, N - 1
                     S = ZERO
                     DO I = 0, J - K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(i,j-k)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
*                    i=j-k
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    A(j-k,j-k)
                     S = S + AA
                     WORK( J-K ) = WORK( J-K ) + S
                     I = I + 1
                     S = ABS( REAL( A( I+J*LDA ) ) )
*                    A(j,j)
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,l)
                        WORK( L ) = WORK( L ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               ELSE
*                 ilu=1 & uplo = 'L'
                  K = K + 1
*                 k=(n+1)/2 for n odd and ilu=1
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K - 2
*                    process
                     S = ZERO
                     DO I = 0, J - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    i=j so process of A(j,j)
                     S = S + AA
                     WORK( J ) = S
*                    is initialised here
                     I = I + 1
*                    i=j process A(j+k,j+k)
                     AA = ABS( REAL( A( I+J*LDA ) ) )
                     S = AA
                     DO L = K + J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(l,k+j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( K+J ) = WORK( K+J ) + S
                  END DO
*                 j=k-1 is special :process col A(k-1,0:k-1)
                  S = ZERO
                  DO I = 0, K - 2
                     AA = ABS( A( I+J*LDA ) )
*                    A(k,i)
                     WORK( I ) = WORK( I ) + AA
                     S = S + AA
                  END DO
*                 i=k-1
                  AA = ABS( REAL( A( I+J*LDA ) ) )
*                 A(k-1,k-1)
                  S = S + AA
                  WORK( I ) = S
*                 done with col j=k+1
                  DO J = K, N - 1
*                    process col j of A = A(j,0:k-1)
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               END IF
            ELSE
*              n is even & A is k=n/2 by n+1
               IF( ILU.EQ.0 ) THEN
*                 uplo = 'U'
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
                  DO J = 0, K - 1
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,i+k)
                        WORK( I+K ) = WORK( I+K ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = S
                  END DO
*                 j=k
                  AA = ABS( REAL( A( 0+J*LDA ) ) )
*                 A(k,k)
                  S = AA
                  DO I = 1, K - 1
                     AA = ABS( A( I+J*LDA ) )
*                    A(k,k+i)
                     WORK( I+K ) = WORK( I+K ) + AA
                     S = S + AA
                  END DO
                  WORK( J ) = WORK( J ) + S
                  DO J = K + 1, N - 1
                     S = ZERO
                     DO I = 0, J - 2 - K
                        AA = ABS( A( I+J*LDA ) )
*                       A(i,j-k-1)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
*                    i=j-1-k
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    A(j-k-1,j-k-1)
                     S = S + AA
                     WORK( J-K-1 ) = WORK( J-K-1 ) + S
                     I = I + 1
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    A(j,j)
                     S = AA
                     DO L = J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j,l)
                        WORK( L ) = WORK( L ) + AA
                        S = S + AA
                     END DO
                     WORK( J ) = WORK( J ) + S
                  END DO
*                 j=n
                  S = ZERO
                  DO I = 0, K - 2
                     AA = ABS( A( I+J*LDA ) )
*                    A(i,k-1)
                     WORK( I ) = WORK( I ) + AA
                     S = S + AA
                  END DO
*                 i=k-1
                  AA = ABS( REAL( A( I+J*LDA ) ) )
*                 A(k-1,k-1)
                  S = S + AA
                  WORK( I ) = WORK( I ) + S
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               ELSE
*                 ilu=1 & uplo = 'L'
                  DO I = K, N - 1
                     WORK( I ) = ZERO
                  END DO
*                 j=0 is special :process col A(k:n-1,k)
                  S = ABS( REAL( A( 0 ) ) )
*                 A(k,k)
                  DO I = 1, K - 1
                     AA = ABS( A( I ) )
*                    A(k+i,k)
                     WORK( I+K ) = WORK( I+K ) + AA
                     S = S + AA
                  END DO
                  WORK( K ) = WORK( K ) + S
                  DO J = 1, K - 1
*                    process
                     S = ZERO
                     DO I = 0, J - 2
                        AA = ABS( A( I+J*LDA ) )
*                       A(j-1,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     AA = ABS( REAL( A( I+J*LDA ) ) )
*                    i=j-1 so process of A(j-1,j-1)
                     S = S + AA
                     WORK( J-1 ) = S
*                    is initialised here
                     I = I + 1
*                    i=j process A(j+k,j+k)
                     AA = ABS( REAL( A( I+J*LDA ) ) )
                     S = AA
                     DO L = K + J + 1, N - 1
                        I = I + 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(l,k+j)
                        S = S + AA
                        WORK( L ) = WORK( L ) + AA
                     END DO
                     WORK( K+J ) = WORK( K+J ) + S
                  END DO
*                 j=k is special :process col A(k,0:k-1)
                  S = ZERO
                  DO I = 0, K - 2
                     AA = ABS( A( I+J*LDA ) )
*                    A(k,i)
                     WORK( I ) = WORK( I ) + AA
                     S = S + AA
                  END DO
*
*                 i=k-1
                  AA = ABS( REAL( A( I+J*LDA ) ) )
*                 A(k-1,k-1)
                  S = S + AA
                  WORK( I ) = S
*                 done with col j=k+1
                  DO J = K + 1, N
*
*                    process col j-1 of A = A(j-1,0:k-1)
                     S = ZERO
                     DO I = 0, K - 1
                        AA = ABS( A( I+J*LDA ) )
*                       A(j-1,i)
                        WORK( I ) = WORK( I ) + AA
                        S = S + AA
                     END DO
                     WORK( J-1 ) = WORK( J-1 ) + S
                  END DO
                  I = ISAMAX( N, WORK, 1 )
                  VALUE = WORK( I-1 )
               END IF
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
*       Find normF(A).
*
         K = ( N+1 ) / 2
         SCALE = ZERO
         S = ONE
         IF( NOE.EQ.1 ) THEN
*           n is odd
            IF( IFM.EQ.1 ) THEN
*              A is normal & A is n by k
               IF( ILU.EQ.0 ) THEN
*                 A is upper
                  DO J = 0, K - 3
                     CALL CLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S )
*                    L at A(k,0)
                  END DO
                  DO J = 0, K - 1
                     CALL CLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S )
*                    trap U at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  L = K - 1
*                 -> U(k,k) at A(k-1,0)
                  DO I = 0, K - 2
                     AA = REAL( A( L ) )
*                    U(k+i,k+i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    U(i,i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
                  AA = REAL( A( L ) )
*                 U(n-1,n-1)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
               ELSE
*                 ilu=1 & A is lower
                  DO J = 0, K - 1
                     CALL CLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S )
*                    trap L at A(0,0)
                  END DO
                  DO J = 1, K - 2
                     CALL CLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S )
*                    U at A(0,1)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  AA = REAL( A( 0 ) )
*                 L(0,0) at A(0,0)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
                  L = LDA
*                 -> L(k,k) at A(0,1)
                  DO I = 1, K - 1
                     AA = REAL( A( L ) )
*                    L(k-1+i,k-1+i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    L(i,i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
               END IF
            ELSE
*              A is xpose & A is k by n
               IF( ILU.EQ.0 ) THEN
*                 A**H is upper
                  DO J = 1, K - 2
                     CALL CLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S )
*                    U at A(0,k)
                  END DO
                  DO J = 0, K - 2
                     CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                    k by k-1 rect. at A(0,0)
                  END DO
                  DO J = 0, K - 2
                     CALL CLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1,
     $                            SCALE, S )
*                    L at A(0,k-1)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  L = 0 + K*LDA - LDA
*                 -> U(k-1,k-1) at A(0,k-1)
                  AA = REAL( A( L ) )
*                 U(k-1,k-1)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
                  L = L + LDA
*                 -> U(0,0) at A(0,k)
                  DO J = K, N - 1
                     AA = REAL( A( L ) )
*                    -> U(j-k,j-k)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    -> U(j,j)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
               ELSE
*                 A**H is lower
                  DO J = 1, K - 1
                     CALL CLASSQ( J, A( 0+J*LDA ), 1, SCALE, S )
*                    U at A(0,0)
                  END DO
                  DO J = K, N - 1
                     CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                    k by k-1 rect. at A(0,k)
                  END DO
                  DO J = 0, K - 3
                     CALL CLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S )
*                    L at A(1,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  L = 0
*                 -> L(0,0) at A(0,0)
                  DO I = 0, K - 2
                     AA = REAL( A( L ) )
*                    L(i,i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    L(k+i,k+i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
*                 L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1)
                  AA = REAL( A( L ) )
*                 L(k-1,k-1) at A(k-1,k-1)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
               END IF
            END IF
         ELSE
*           n is even
            IF( IFM.EQ.1 ) THEN
*              A is normal
               IF( ILU.EQ.0 ) THEN
*                 A is upper
                  DO J = 0, K - 2
                     CALL CLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S )
*                 L at A(k+1,0)
                  END DO
                  DO J = 0, K - 1
                     CALL CLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S )
*                 trap U at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  L = K
*                 -> U(k,k) at A(k,0)
                  DO I = 0, K - 1
                     AA = REAL( A( L ) )
*                    U(k+i,k+i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    U(i,i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
               ELSE
*                 ilu=1 & A is lower
                  DO J = 0, K - 1
                     CALL CLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S )
*                    trap L at A(1,0)
                  END DO
                  DO J = 1, K - 1
                     CALL CLASSQ( J, A( 0+J*LDA ), 1, SCALE, S )
*                    U at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  L = 0
*                 -> L(k,k) at A(0,0)
                  DO I = 0, K - 1
                     AA = REAL( A( L ) )
*                    L(k-1+i,k-1+i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    L(i,i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
               END IF
            ELSE
*              A is xpose
               IF( ILU.EQ.0 ) THEN
*                 A**H is upper
                  DO J = 1, K - 1
                     CALL CLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S )
*                 U at A(0,k+1)
                  END DO
                  DO J = 0, K - 1
                     CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                 k by k rect. at A(0,0)
                  END DO
                  DO J = 0, K - 2
                     CALL CLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE,
     $                            S )
*                 L at A(0,k)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  L = 0 + K*LDA
*                 -> U(k,k) at A(0,k)
                  AA = REAL( A( L ) )
*                 U(k,k)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
                  L = L + LDA
*                 -> U(0,0) at A(0,k+1)
                  DO J = K + 1, N - 1
                     AA = REAL( A( L ) )
*                    -> U(j-k-1,j-k-1)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    -> U(j,j)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
*                 L=k-1+n*lda
*                 -> U(k-1,k-1) at A(k-1,n)
                  AA = REAL( A( L ) )
*                 U(k,k)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
               ELSE
*                 A**H is lower
                  DO J = 1, K - 1
                     CALL CLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S )
*                 U at A(0,1)
                  END DO
                  DO J = K + 1, N
                     CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S )
*                 k by k rect. at A(0,k+1)
                  END DO
                  DO J = 0, K - 2
                     CALL CLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S )
*                 L at A(0,0)
                  END DO
                  S = S + S
*                 double s for the off diagonal elements
                  L = 0
*                 -> L(k,k) at A(0,0)
                  AA = REAL( A( L ) )
*                 L(k,k) at A(0,0)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
                  L = LDA
*                 -> L(0,0) at A(0,1)
                  DO I = 0, K - 2
                     AA = REAL( A( L ) )
*                    L(i,i)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     AA = REAL( A( L+1 ) )
*                    L(k+i+1,k+i+1)
                     IF( AA.NE.ZERO ) THEN
                        IF( SCALE.LT.AA ) THEN
                           S = ONE + S*( SCALE / AA )**2
                           SCALE = AA
                        ELSE
                           S = S + ( AA / SCALE )**2
                        END IF
                     END IF
                     L = L + LDA + 1
                  END DO
*                 L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k)
                  AA = REAL( A( L ) )
*                 L(k-1,k-1) at A(k-1,k)
                  IF( AA.NE.ZERO ) THEN
                     IF( SCALE.LT.AA ) THEN
                        S = ONE + S*( SCALE / AA )**2
                        SCALE = AA
                     ELSE
                        S = S + ( AA / SCALE )**2
                     END IF
                  END IF
               END IF
            END IF
         END IF
         VALUE = SCALE*SQRT( S )
      END IF
*
      CLANHF = VALUE
      RETURN
*
*     End of CLANHF
*
      END


! make clean ; make ; nvprof -f -o test.nvvp ./test
program derived_type_openmp
	use operation_def, only : multiplication
	use setup, only : setup_types, remove_types, op_ptr, op_ptr_b

  implicit none
	real(kind=8), dimension(:,:), pointer :: v, dv
	integer :: a, i, iop
	character(len=32) :: arg

	! Size of arrays to allocate
  a = 100
  ! Operation value to use
  iop = 2

	! Setup derived types
	call setup_types(a,iop)

	! Allocate arrays to operate on
	allocate( v(a,a), dv(a,a) )

	! Initialize v
	v = 4

	print *, 'v = ', v(1,1)
	print *, 'array = ',op_ptr%array(1,1)
	print *, 'type-bound array = ',op_ptr_b%array(1,1)

! Call multiplication operator
print *, 'Calling operations....'

!===============================================================!
!== Direct call to multiply ====================================!
	! Perform operation on v to get dv
	!$omp target data map(to:v) map(from:dv)
	do i=1,10
		call multiplication(op_ptr, v, dv, a)
	end do
	!$omp end target data

	print *, 'dv = v*array = ',dv(1,1)

!===============================================================!
!== Type-bound multiply procedure ==============================!
	! Perform operation on v to get dv
	!$omp target data map(to:v) map(from:dv)
	do i=1,10
		call op_ptr_b%multiply(v, dv, a)
	end do
	!$omp end target data

	print *, 'dv = v*array = ',dv(1,1)

	! Deallocate arrays and derived types
	deallocate(v,dv)
	call remove_types()

end program derived_type_openmp


C NCLFORTSTART
      subroutine weibfit(maxn,xin,xmsg,nmin,level,weib,ier)
      implicit none
C                                                 ! INPUT
      integer maxn, nmin, ier
      double precision xin(maxn), xmsg, level
C                                                 ! OUTPUT
      double precision  weib(6)
C NCLEND
C
C
C Modified from:  http://ftp.uni-bayreuth.de/math/statlib/jqt/29-1-2
C Shea directory name: weibull.2_param_mle.ncl.f
c
c  Weibull Maximum Likelihood Parameter Estimates with Censored Data
c  J. Bert Keats, Frederick P. Lawrence, and F. K. Wang
c  Journal of Quality Technology, Volume 29, Number 1, pp. 105--110, January 1997

C                                                 ! LOCAL
      double precision x(maxn)
c     double precision y(maxn), cycle(maxn)
C      integer censor(maxn)
C****************************************************
C* FORTRAN PROGRAM USES MAXIMUM LIKELIHOOD TO       *
C* ESTIMATE THE PARAMETERS OF TWO-PARAMETER WEIBULL *
C* DISTRIBUTION. THE PROGRAM CAN BE USED FOR ALL    *
C* CENSORING CASES:                                 *
C*     CASE 1: MULTIPLY CENSORED DATA               *
C*     CASE 2: SINGLY CENSORED DATA                 *
C*     CASE 3: COMPLETE DATA                        *
C* CENSORED TYPE (0: FAILURE; 1: NON-FAILURE)*
C****************************************************
      INTEGER I,R,S,J,L,CC,ERROR,CASE
C     INTEGER INDEX
      INTEGER N,K,K1
      DOUBLE PRECISION BETA, THETA
      DOUBLE PRECISION PI,T2,T3,T4,ST1,ST2,NUM,NUM1
      DOUBLE PRECISION VARB,VART,COVBT,DEM1,DEM2,DEM3
      DOUBLE PRECISION S1R,S2R,S3R,S4R,S2S,S3S,S4S
      DOUBLE PRECISION DENOM,DENOM1,DENOM2,DENOM3,DENOM4
      DOUBLE PRECISION CON,IB,IT,COV,LOW1,LOW2,UP1,UP2
      DOUBLE PRECISION ALPHA,NORM,DELTA,L1,L2

      ier = 0
      do i=1,6
         weib(i) = xmsg
      end do

      case  = 3

      n = 0
      do 10 i=1,maxn
         if (xin(i).ne.xmsg .and. xin(i).gt.0.0d0) then
             n = n+1
         end if
10    continue

      if (n.lt.nmin) then
c c c     print *,"weibfit: not enough values: n=",n
          ier = 1
          return
      end if

      ALPHA = (1.0 - LEVEL) / 2.0D0
      R = 0
      S = 0
      J = 1
      L = 1
      DO 20 I=1,N
C C C   IF (CENSOR(I) .EQ. 0) THEN
        IF (xin(i).ne.xmsg .and. xin(i).gt.0.0d0) THEN
C C C     X(J) = CYCLE(I)
          X(J) = xin(i)
          J = J + 1
          R = R + 1
C C C   ELSE
C C C     Y(L) = CYCLE(I)
C C C     L = L + 1
C C C     S = S + 1
        END IF
20      CONTINUE
C
C MENON'S ESTIMATE OF BETA AS INITIAL
C APPROXIMATION OF BETA
C
      PI  = 3.141592653589793
      ST1 = 0
      ST2 = 0
      DO I = 1, R
        ST1 = ST1 +  DLOG(X(I))
        ST2 = ST2 + ( DLOG(X(I)))**2
      END DO

      S1R = ST1
      ST1 = (ST1**2)/(FLOAT(R))
      BETA = (6.0 * (ST2 - ST1))/((PI**2)*(FLOAT(R - 1)))
      IF (BETA .EQ. 0.0) BETA = .0001
      BETA = 1. / SQRT(BETA)
      CC = 0
      DELTA = 0
C
C NEWTON-RAPHSON ITERATIVE ESTIMATE OF BETA
C
      DO 100 K = 1,25
        S2R = 0
        S3R = 0
        S4R = 0
        S2S = 0
        S3S = 0
        S4S = 0
        DO 80 I = 1,R
          S2R = S2R + X(I)**BETA
          S3R = S3R + (X(I)**BETA) *  DLOG(X(I))
          S4R = S4R + (X(I)**BETA) * ( DLOG(X(I))**2)
80        CONTINUE
C C C     DO 85 I = 1,S
C C C      S2S = S2S + Y(I)**BETA
C C C      S3S = S3S + (Y(I)**BETA) *  DLOG(Y(I))
C C C      S4S = S4S + (Y(I)**BETA) * ( DLOG(Y(I))**2)
C C C 85   CONTINUE
        NUM1 = (S3R + S3S) / (S2R + S2S)
        NUM = (1. / BETA) + (S1R / R) - NUM1
        DENOM1 = (S3R + S3S)**2
        DENOM2 = (S2R + S2S) * (S4R + S4S)
        DENOM3 = (S2R + S2S)**2
        DENOM4 = 1.0 / BETA**2
        DENOM = DENOM4 - ((DENOM1 - DENOM2) / DENOM3)
        DELTA = NUM / DENOM
        BETA = BETA + DELTA
        K1 = K
C
C TEST FOR CONVERGENCE
C
        IF (ABS(DELTA) .LT. 0.0001) THEN
          CC = 1
          GOTO 105
        END IF
100     CONTINUE
C
C INDICATE NON-CONVERGENCE
C
105   IF (CC .EQ. 0) THEN
c c c   WRITE(*,*) ' THE NEWTON-RAPHSON IS NOT ', *  'CONVERGED'
          ier   = 2
          return
      ELSE
C
C IF CONVERGENCE HAS OCCURRED CALCULATE THETA & BETA
C
        S2R = 0
        S3R = 0
        S4R = 0
        S2S = 0
        S3S = 0
        S4S = 0
        DO 90 I = 1,R
          S2R = S2R + X(I)**BETA
          S3R = S3R + (X(I)**BETA) *  DLOG(X(I))
          S4R = S4R + (X(I)**BETA) * ( DLOG(X(I))**2)
90        CONTINUE
C C C   DO 95 I = 1,S
C C C     S2S = S2S + Y(I)**BETA
C C C     S3S = S3S + (Y(I)**BETA) *  DLOG(Y(I))
C C C     S4S = S4S + (Y(I)**BETA) * ( DLOG(Y(I))**2)
C C C   95        CONTINUE
        T2 = S2R + S2S
        T3 = S3R + S3S
        T4 = S4R + S4S
        THETA = (T2 / FLOAT(R))**(1.0 / BETA)
      END IF
C
C COMPUTE THE CONFIDENCE INTERVAL OF THE PARAMETERS
C THETA & BETA
C
      DEM1 = THETA**BETA
      DEM2 = THETA**(1 + BETA)
      DEM3 = THETA**(2 + BETA)
      L1   =  DLOG(THETA)
      L2   = ( DLOG(THETA))**2
      IB   = R / BETA**2 + (L2 * T2 - 2 * L1 * T3 + T4)/ DEM1
      IT   = (BETA * (BETA + 1) / DEM3 * T2) - (R * BETA / THETA**2)
      COV  = R / THETA - (T2 - BETA * L1 * T2 + BETA * T3) / DEM2

C Determinant of 2x2 matrix
C    [A  B               [Var(B)    Cov(B,T)
C     C  D]               Cov(B,T)  VAR(T)  ]
C          = A*D-B*C     = Var(B)*VAR(T)-Cov(B,T)**2
C                           IB     iT     COV**2

      CON  = (IB *IT) - COV**2
      VARB = IT / CON
      VART = IB / CON
      COVBT= COV / CON
C                                    AVOID ANY NAMING CONFLICT
C C C CALL NORMAL(ALPHA,NORM,ERROR)
      CALL QNORMALQ(ALPHA,NORM,ERROR)

      LOW1 = BETA  - NORM * SQRT(VARB)
      UP1  = BETA  + NORM * SQRT(VARB)
      LOW2 = THETA - NORM * SQRT(VART)
      UP2  = THETA + NORM * SQRT(VART)

      weib(1) = BETA
      weib(2) = THETA
      weib(3) = LOW1
      weib(4) = UP1
      weib(5) = LOW2
      weib(6) = UP2

      return

C C C IF (CASE .EQ. 1) THEN
C C C   WRITE(*,300) N,R,S
C C C   WRITE(1,300) N,R,S
C300C C CFORMAT(10X,'MAXIMUM LIKELIHOOD ESTIMATION',//,
C C C*C C C10X,'FOR MULTIPLY CENSORED DATA',//,
C C C*C C C10X,'SAMPLE SIZE IS ',I3,//,
C C C*C C C10X,'NUMBER OF FAILURES IS ',I3,//,
C C C*C C C10X,'NUMBER OF NON-FAILURES IS ',I3,//)
C C C ELSE IF (CASE .EQ. 2) THEN
C C C   WRITE(*,301) N,R,S
C C C   WRITE(1,301) N,R,S
C301C C CFORMAT(10X,'MAXIMUM LIKELIHOOD ESTIMATION',//,
C C C*   10X,'FOR SINGLY CENSORED DATA',//,
C C C*   10X,'SAMPLE SIZE IS ',I3,//,
C C C*   10X,'NUMBER OF FAILURES IS ',I3,//,
C C C*   10X,'NUMBER OF NON-FAILURES IS ',I3,//)

C C C ELSE IF (CASE .EQ. 3) THEN
C C C   WRITE(*,302) N,R,S
C C C   WRITE(1,302) N,R,S
C302C C CFORMAT(10X,'MAXIMUM LIKELIHOOD ESTIMATION',//,
C C C*    10X,'FOR COMPLETE DATA',//,
C C C*    10X,'SAMPLE SIZE IS ',I3,//,
C C C*    10X,'NUMBER OF FAILURES IS ',I3,//,
C C C*    10X,'NUMBER OF NON-FAILURES IS ',I3,//)
C C C END IF

C C C LEVEL = LEVEL*100.
C C C WRITE(*,600) LEVEL
C C C WRITE(1,600) LEVEL
C600  FORMAT(25X,F5.2,' % CONFIDENCE INTERVAL',/,
C C C*25X,'--------------------------',/,
C C C*1X,'PARAMETER ESTIMATE ',6X,' LOWER LIMIT ',
C C C*'UPPER LIMIT',/,
C C C*1X,'------------------------------------------',
C C C*'--------',/)
C C C WRITE(*,700) BETA,LOW1,UP1
C C C WRITE(1,700) BETA,LOW1,UP1
C C C700   FORMAT(3X,'BETA',5X,F9.4,5X,F9.4,4X,F9.4,/)
C C C WRITE(*,800) THETA,LOW2,UP2
C C C WRITE(1,800) THETA,LOW2,UP2
C800  FORMAT(3X,'THETA',4X,F9.4,5X,F9.4,4X,F9.4,/)
      RETURN
      END
C****************************************************
C* SUBROUTINE TO GENERATE THE INVERSE NORMAL VALUE, *
C* TAKEN FROM: ``STATISTICAL COMPUTING'' BY KENNEDY,*
C* W. J. & GENTLE, J. E. (1980), pp. 95.            *
C****************************************************
      SUBROUTINE QNORMALQ(ALPHA,NORM,ERROR)
C C C SUBROUTINE NORMAL(ALPHA,NORM,ERROR)
      implicit none
      INTEGER ERROR
      DOUBLE PRECISION ALPHA,NORM,LIM,P0,P1,P2,P3,P4
      DOUBLE PRECISION Q0,Q1,Q2,Q3,Q4,Y
      LIM = 1.0D-20
      P0 = -0.322232431088
      P1 = -1.0
      P2 = -0.342242088547
      P3 = -0.0204231210245
      P4 = -0.453642210148D-4
      Q0 = 0.0993484626060
      Q1 = 0.588581570495
      Q2 = 0.531103462366
      Q3 = 0.103537752850
      Q4 = 0.0038560700634
      ERROR = 1
      NORM = 0
      IF (ALPHA .GT. 0.5) ALPHA = 1. - ALPHA
      IF (ALPHA .LT. LIM) THEN
        NORM = 0
        GO TO 10
      END IF
      ERROR = 0
      IF (ALPHA .EQ. 0.5) THEN
        NORM = 0
        GO TO 10
      END IF
      Y = DSQRT(DLOG(1. / ALPHA**2))
      NORM = Y + ((((Y*P4+P3)*Y+P2)*Y+P1)*Y+P0)/
     *           ((((Y*Q4+Q3)*Y+Q2)*Y+Q1)*Y+Q0)
      IF (ALPHA .GT. 0.5) NORM = -NORM
10    RETURN
      END


program main6
    use Func
    use Calc
    use Util
    use Plotlib
    implicit none

!   Command-line Args
    integer :: argc

    DEBUG_MODE = .TRUE.

!   Random seed definition
    call init_random_seed()

!   Get Command-Line Args
    argc = iargc()

    if (argc == 0) then
        goto 100
    else
        goto 11
    end if

!   ====== Begin =====================================

!   ====== Success ===================================
10  call info(':: Sucesso ::')
    goto 1
!   ====== Errors ====================================
11  call error('Este programa não aceita parâmetros.')
    goto 1
!   ====== Finish ====================================
1   stop
!   ====== Program ===================================
100 call Q1
    goto 200

200 call Q2
    goto 300

300 call Q3
    goto 400

400 call QB
    goto 10

    contains
        subroutine Q1
            implicit none
            integer :: n, i, j
            integer :: k = 0
            double precision, dimension(:), allocatable :: t, y
            double precision, dimension(4) :: dt
            type(StringArray), dimension(:), allocatable :: legend
            type(StringArray), dimension(:), allocatable :: title

            allocate(legend(4), title(4))

            dt(1) = 5.0D-1
            dt(2) = 2.5D-1
            dt(3) = 1.0D-1
            dt(4) = 0.1D-1

            title(1)%str = "Δt = 0.50"
            title(2)%str = "Δt = 0.25"
            title(3)%str = "Δt = 0.10"
            title(4)%str = "Δt = 0.01"

            legend(1)%str = "Euler"
            legend(2)%str = "Runge-Kutta II"
            legend(3)%str = "Runge-Kutta IV"
            legend(4)%str = "y(t)"

            call blue(ENDL//"1)"//ENDL//F13_NAME)

            call info(":: Plotagem ::")

            call begin_plot(fname='L6-Q1', size_w='12in', size_h='9in')
            call subplots(2, 2)

            do i=1,2
                do j=1,2
                    k = k + 1

                    call linspace(F13_A, F13_B, dt(k), n, t)

                    allocate(y(n))

                    !call info(":: Método de Euler ::")
                    y = ode_solve(df13, F13_Y0, t, n, kind='euler')
                    call subplot(i, j, t, y, n)

                    !call info(":: Método de Runge-Kutta de 2ª ordem ::")
                    y = ode_solve(df13, F13_Y0, t, n, kind='runge-kutta2')
                    call subplot(i, j, t, y, n)

                    !call info(":: Método de Runge-Kutta de 4ª ordem ::")
                    y = ode_solve(df13, F13_Y0, t, n, kind='runge-kutta4')
                    call subplot(i, j, t, y, n)

                    y = (/ (f13(t(j)), j=1, n) /)
                    call subplot(i, j, t, y, n)

                    call subplot_config(i, j, &
                    title=title(k)%str, xlabel='t', ylabel='y(t)', grid=.TRUE., legend=legend)

                    deallocate(t, y)
                end do
            end do

            call render_plot(clean=.TRUE.)

            deallocate(legend, title)
        end subroutine

        subroutine Q2
            integer :: n, i, j
            integer :: k = 0
            double precision, dimension(:), allocatable :: t, y
            double precision, dimension(4) :: dt
            type(StringArray), dimension(:), allocatable :: legend
            type(StringArray), dimension(:), allocatable :: title

            allocate(legend(2), title(4))

            dt(1) = 5.0D-1
            dt(2) = 2.5D-1
            dt(3) = 1.0D-1
            dt(4) = 0.1D-1

            title(1)%str = "Δt = 0.50"
            title(2)%str = "Δt = 0.25"
            title(3)%str = "Δt = 0.10"
            title(4)%str = "Δt = 0.01"

            legend(1)%str = "Série de Taylor"
            legend(2)%str = "Runge-Kutta-Nystrom"

            call blue(ENDL//"2)"//ENDL//F14_NAME)

            call info(":: Plotagem ::")

            call begin_plot(fname='L6-Q2', size_w='12in', size_h='9in')
            call subplots(2, 2)

            do i=1,2
                do j=1,2
                    k = k + 1

                    call linspace(F14_A, F14_B, dt(k), n, t)

                    allocate(y(n))

                    y = ode2_solve(d2f14, F14_Y0, F14_DY0, t, n, kind='taylor')
                    call subplot(i, j, t, y, n)

                    y = ode2_solve(d2f14, F14_Y0, F14_DY0, t, n, kind='runge-kutta-nystrom')
                    call subplot(i, j, t, y, n)

                    call subplot_config(i, j, &
                    title=title(k)%str, xlabel='t', ylabel='y(t)', grid=.TRUE., legend=legend)

                    deallocate(t, y)
                end do
            end do

            call render_plot(clean=.TRUE.)

            deallocate(legend, title)
        end subroutine

        subroutine Q3
            integer :: n, i, j
            integer :: k = 0
            double precision, dimension(:), allocatable :: t, y
            double precision, dimension(4) :: dt
            type(StringArray), dimension(:), allocatable :: legend
            type(StringArray), dimension(:), allocatable :: title

            allocate(legend(2), title(4))

            dt(1) = 5.0D-1
            dt(2) = 4.0D-1
            dt(3) = 3.0D-1
            dt(4) = 2.0D-1

            title(1)%str = "Δt = 0.50"
            title(2)%str = "Δt = 0.40"
            title(3)%str = "Δt = 0.30"
            title(4)%str = "Δt = 0.20"

            legend(1)%str = "Série de Taylor"
            legend(2)%str = "Runge-Kutta-Nystrom"

            call blue(ENDL//"3)"//ENDL//F15_NAME)

            call begin_plot(fname='L6-Q3', size_w='12in', size_h='9in')
            call subplots(2, 2)

            do i=1,2
                do j=1,2
                    k = k + 1

                    call linspace(F15_A, F15_B, dt(k), n, t)

                    allocate(y(n))

                    y = ode2_solve(d2f15, F15_Y0, F15_DY0, t, n, kind='taylor')
                    call subplot(i, j, t, y, n)

                    y = ode2_solve(d2f15, F15_Y0, F15_DY0, t, n, kind='runge-kutta-nystrom')
                    call subplot(i, j, t, y, n)

                    call subplot_config(i, j, &
                    title=title(k)%str, xlabel='t', ylabel='z(t)', grid=.TRUE., legend=legend)

                    deallocate(t, y)
                end do
            end do

            call render_plot(clean=.TRUE.)

            deallocate(legend, title)
        end subroutine

        subroutine QB
            integer :: n, i, j
            integer :: k = 0
            double precision, dimension(:), allocatable :: t, y
            double precision, dimension(4) :: dt
            type(StringArray), dimension(:), allocatable :: legend
            type(StringArray), dimension(:), allocatable :: title

            allocate(legend(2), title(4))

            dt(1) = 5.0D-1
            dt(2) = 2.5D-1
            dt(3) = 1.0D-1
            dt(4) = 0.1D-1

            title(1)%str = "Δt = 0.50"
            title(2)%str = "Δt = 0.25"
            title(3)%str = "Δt = 0.10"
            title(4)%str = "Δt = 0.01"

            legend(1)%str = "Série de Taylor"
            legend(2)%str = "Runge-Kutta-Nystrom"

            call blue(ENDL//"Bônus)"//ENDL//F15_NAME)

            call info(":: Plotagem ::")

            call begin_plot(fname='L6-QB', size_w='12in', size_h='9in')
            call subplots(2, 2)

            do i=1,2
                do j=1,2
                    k = k + 1

                    call linspace(F15_A, F15_B, dt(k), n, t)

                    allocate(y(n))

                    y = ode2_solve(d2f15, F15_BY0, F15_DY0, t, n, kind='taylor')
                    call subplot(i, j, t, y, n)

                    y = ode2_solve(d2f15, F15_BY0, F15_DY0, t, n, kind='runge-kutta-nystrom')
                    call subplot(i, j, t, y, n)

                    call subplot_config(i, j, &
                    title=title(k)%str, xlabel='t', ylabel='z(t)', grid=.TRUE., legend=legend)

                    deallocate(t, y)
                end do
            end do

            call render_plot(clean=.TRUE.)

            deallocate(legend, title)
        end subroutine
end program main6


program main

    !! The "main" routine of the program
    !!
    !! This is where execution starts when running the program

    use processor
    use fea

    implicit none

    ! Read model data
    call input

    ! Initialize problem
    call initial

	!Choose what kind of FEA
	select case (antype)
        case ('static')
            ! Calculate displacements
    		call displ
        case ('static_nl')
            write (*, *) 'static_nl analysis is not implemented'
            stop
        case ('modal')
            ! Calculate eigen values
    		call eigen
        case ('angle')
            write (*, *) 'angle analysis is not implemented'
            stop
        case ('trans')
            ! Calculate transient response history
            call stopwatch('star')
            call trans
            call stopwatch('stop')
        case default
            write (*, *) 'No type was given for analysis, Using default static analysis'
            call displ
    end select

    ! Close plot window(s)
    call plot( done )

end program main


module error_function

implicit none
private
save

public :: erf, erfc, erfcx

interface erf
   module procedure erf_r4
   module procedure derf
end interface

interface erfc
   module procedure erfc_r4
   module procedure derfc
end interface

interface erfcx
   module procedure erfcx_r4
   module procedure derfcx
end interface

integer, parameter :: r4 = selected_real_kind(6)
integer, parameter :: r8 = selected_real_kind(12)

contains
SUBROUTINE CALERF_r8(ARG, RESULT, JINT)
   integer, parameter :: rk = r8
   real(rk), intent(in) :: arg
   integer, intent(in) :: jint
   real(rk), intent(out) :: result
   INTEGER :: I
   real(rk) :: X, Y, YSQ, XNUM, XDEN, DEL
   real(rk), parameter :: ZERO = 0.0E0_rk
   real(rk), parameter :: FOUR = 4.0E0_rk
   real(rk), parameter :: ONE = 1.0E0_rk
   real(rk), parameter :: HALF = 0.5E0_rk
   real(rk), parameter :: TWO = 2.0E0_rk
   real(rk), parameter :: SQRPI = 5.6418958354775628695E-1_rk
   real(rk), parameter :: THRESH = 0.46875E0_rk
   real(rk), parameter :: SIXTEN = 16.0E0_rk
   real(rk), parameter :: XINF = 1.79E308_r8
   real(rk), parameter :: XNEG = -26.628E0_r8
   real(rk), parameter :: XSMALL = 1.11E-16_r8
   real(rk), parameter :: XBIG = 26.543E0_r8
   real(rk), parameter :: XHUGE = 6.71E7_r8
   real(rk), parameter :: XMAX = 2.53E307_r8
   real(rk), parameter :: A(5) = (/ 3.16112374387056560E00_rk, 1.13864154151050156E02_rk, &
                                    3.77485237685302021E02_rk, 3.20937758913846947E03_rk, &
                                    1.85777706184603153E-1_rk /)
   real(rk), parameter :: B(4) = (/ 2.36012909523441209E01_rk, 2.44024637934444173E02_rk, &
                                    1.28261652607737228E03_rk, 2.84423683343917062E03_rk /)
   real(rk), parameter :: C(9) = (/ 5.64188496988670089E-1_rk, 8.88314979438837594E00_rk, &
                                    6.61191906371416295E01_rk, 2.98635138197400131E02_rk, &
                                    8.81952221241769090E02_rk, 1.71204761263407058E03_rk, &
                                    2.05107837782607147E03_rk, 1.23033935479799725E03_rk, &
                                    2.15311535474403846E-8_rk /)
   real(rk), parameter :: D(8) = (/ 1.57449261107098347E01_rk, 1.17693950891312499E02_rk, &
                                    5.37181101862009858E02_rk, 1.62138957456669019E03_rk, &
                                    3.29079923573345963E03_rk, 4.36261909014324716E03_rk, &
                                    3.43936767414372164E03_rk, 1.23033935480374942E03_rk /)
   real(rk), parameter :: P(6) = (/ 3.05326634961232344E-1_rk, 3.60344899949804439E-1_rk, &
                                    1.25781726111229246E-1_rk, 1.60837851487422766E-2_rk, &
                                    6.58749161529837803E-4_rk, 1.63153871373020978E-2_rk /)
   real(rk), parameter :: Q(5) = (/ 2.56852019228982242E00_rk, 1.87295284992346047E00_rk, &
                                    5.27905102951428412E-1_rk, 6.05183413124413191E-2_rk, &
                                    2.33520497626869185E-3_rk /)
   X = ARG
   Y = ABS(X)
   IF (Y .LE. THRESH) THEN
      YSQ = ZERO
      IF (Y .GT. XSMALL) YSQ = Y * Y
      XNUM = A(5)*YSQ
      XDEN = YSQ
      DO I = 1, 3
         XNUM = (XNUM + A(I)) * YSQ
         XDEN = (XDEN + B(I)) * YSQ
      end do
      RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
      IF (JINT .NE. 0) RESULT = ONE - RESULT
      IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT
      GO TO 80
   ELSE IF (Y .LE. FOUR) THEN
      XNUM = C(9)*Y
      XDEN = Y
      DO I = 1, 7
         XNUM = (XNUM + C(I)) * Y
         XDEN = (XDEN + D(I)) * Y
      end do
      RESULT = (XNUM + C(8)) / (XDEN + D(8))
      IF (JINT .NE. 2) THEN
         YSQ = AINT(Y*SIXTEN)/SIXTEN
         DEL = (Y-YSQ)*(Y+YSQ)
         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
      END IF
   ELSE
      RESULT = ZERO
      IF (Y .GE. XBIG) THEN
         IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GO TO 30
         IF (Y .GE. XHUGE) THEN
            RESULT = SQRPI / Y
            GO TO 30
         END IF
      END IF
      YSQ = ONE / (Y * Y)
      XNUM = P(6)*YSQ
      XDEN = YSQ
      DO I = 1, 4
         XNUM = (XNUM + P(I)) * YSQ
         XDEN = (XDEN + Q(I)) * YSQ
      end do
      RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
      RESULT = (SQRPI - RESULT) / Y
      IF (JINT .NE. 2) THEN
         YSQ = AINT(Y*SIXTEN)/SIXTEN
         DEL = (Y-YSQ)*(Y+YSQ)
         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
      END IF
   END IF
30 continue
   IF (JINT .EQ. 0) THEN
      RESULT = (HALF - RESULT) + HALF
      IF (X .LT. ZERO) RESULT = -RESULT
   ELSE IF (JINT .EQ. 1) THEN
      IF (X .LT. ZERO) RESULT = TWO - RESULT
   ELSE
      IF (X .LT. ZERO) THEN
         IF (X .LT. XNEG) THEN
            RESULT = XINF
         ELSE
            YSQ = AINT(X*SIXTEN)/SIXTEN
            DEL = (X-YSQ)*(X+YSQ)
            Y = EXP(YSQ*YSQ) * EXP(DEL)
            RESULT = (Y+Y) - RESULT
         END IF
      END IF
   END IF
80 continue
end SUBROUTINE CALERF_r8
SUBROUTINE CALERF_r4(ARG, RESULT, JINT)
   integer, parameter :: rk = r4
   real(rk), intent(in) :: arg
   integer, intent(in) :: jint
   real(rk), intent(out) :: result
   INTEGER :: I
   real(rk) :: X, Y, YSQ, XNUM, XDEN, DEL
   real(rk), parameter :: ZERO = 0.0E0_rk
   real(rk), parameter :: FOUR = 4.0E0_rk
   real(rk), parameter :: ONE = 1.0E0_rk
   real(rk), parameter :: HALF = 0.5E0_rk
   real(rk), parameter :: TWO = 2.0E0_rk
   real(rk), parameter :: SQRPI = 5.6418958354775628695E-1_rk
   real(rk), parameter :: THRESH = 0.46875E0_rk
   real(rk), parameter :: SIXTEN = 16.0E0_rk
   real(rk), parameter :: XINF = 3.40E+38_r4
   real(rk), parameter :: XNEG = -9.382E0_r4
   real(rk), parameter :: XSMALL = 5.96E-8_r4
   real(rk), parameter :: XBIG = 9.194E0_r4
   real(rk), parameter :: XHUGE = 2.90E3_r4
   real(rk), parameter :: XMAX = 4.79E37_r4
   real(rk), parameter :: A(5) = (/ 3.16112374387056560E00_rk, 1.13864154151050156E02_rk, &
                                    3.77485237685302021E02_rk, 3.20937758913846947E03_rk, &
                                    1.85777706184603153E-1_rk /)
   real(rk), parameter :: B(4) = (/ 2.36012909523441209E01_rk, 2.44024637934444173E02_rk, &
                                    1.28261652607737228E03_rk, 2.84423683343917062E03_rk /)
   real(rk), parameter :: C(9) = (/ 5.64188496988670089E-1_rk, 8.88314979438837594E00_rk, &
                                    6.61191906371416295E01_rk, 2.98635138197400131E02_rk, &
                                    8.81952221241769090E02_rk, 1.71204761263407058E03_rk, &
                                    2.05107837782607147E03_rk, 1.23033935479799725E03_rk, &
                                    2.15311535474403846E-8_rk /)
   real(rk), parameter :: D(8) = (/ 1.57449261107098347E01_rk, 1.17693950891312499E02_rk, &
                                    5.37181101862009858E02_rk, 1.62138957456669019E03_rk, &
                                    3.29079923573345963E03_rk, 4.36261909014324716E03_rk, &
                                    3.43936767414372164E03_rk, 1.23033935480374942E03_rk /)
   real(rk), parameter :: P(6) = (/ 3.05326634961232344E-1_rk, 3.60344899949804439E-1_rk, &
                                    1.25781726111229246E-1_rk, 1.60837851487422766E-2_rk, &
                                    6.58749161529837803E-4_rk, 1.63153871373020978E-2_rk /)
   real(rk), parameter :: Q(5) = (/ 2.56852019228982242E00_rk, 1.87295284992346047E00_rk, &
                                    5.27905102951428412E-1_rk, 6.05183413124413191E-2_rk, &
                                    2.33520497626869185E-3_rk /)
   X = ARG
   Y = ABS(X)
   IF (Y .LE. THRESH) THEN
      YSQ = ZERO
      IF (Y .GT. XSMALL) YSQ = Y * Y
      XNUM = A(5)*YSQ
      XDEN = YSQ
      DO I = 1, 3
         XNUM = (XNUM + A(I)) * YSQ
         XDEN = (XDEN + B(I)) * YSQ
      end do
      RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
      IF (JINT .NE. 0) RESULT = ONE - RESULT
      IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT
      GO TO 80
   ELSE IF (Y .LE. FOUR) THEN
      XNUM = C(9)*Y
      XDEN = Y
      DO I = 1, 7
         XNUM = (XNUM + C(I)) * Y
         XDEN = (XDEN + D(I)) * Y
      end do
      RESULT = (XNUM + C(8)) / (XDEN + D(8))
      IF (JINT .NE. 2) THEN
         YSQ = AINT(Y*SIXTEN)/SIXTEN
         DEL = (Y-YSQ)*(Y+YSQ)
         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
      END IF
   ELSE
      RESULT = ZERO
      IF (Y .GE. XBIG) THEN
         IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GO TO 30
         IF (Y .GE. XHUGE) THEN
            RESULT = SQRPI / Y
            GO TO 30
         END IF
      END IF
      YSQ = ONE / (Y * Y)
      XNUM = P(6)*YSQ
      XDEN = YSQ
      DO I = 1, 4
         XNUM = (XNUM + P(I)) * YSQ
         XDEN = (XDEN + Q(I)) * YSQ
      end do
      RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
      RESULT = (SQRPI - RESULT) / Y
      IF (JINT .NE. 2) THEN
         YSQ = AINT(Y*SIXTEN)/SIXTEN
         DEL = (Y-YSQ)*(Y+YSQ)
         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
      END IF
   END IF
30 continue
   IF (JINT .EQ. 0) THEN
      RESULT = (HALF - RESULT) + HALF
      IF (X .LT. ZERO) RESULT = -RESULT
   ELSE IF (JINT .EQ. 1) THEN
      IF (X .LT. ZERO) RESULT = TWO - RESULT
   ELSE
      IF (X .LT. ZERO) THEN
         IF (X .LT. XNEG) THEN
            RESULT = XINF
         ELSE
            YSQ = AINT(X*SIXTEN)/SIXTEN
            DEL = (X-YSQ)*(X+YSQ)
            Y = EXP(YSQ*YSQ) * EXP(DEL)
            RESULT = (Y+Y) - RESULT
         END IF
      END IF
   END IF
80 continue
end SUBROUTINE CALERF_r4
FUNCTION DERF(X)
   integer, parameter :: rk = r8
   real(rk), intent(in) :: X
   real(rk) :: DERF
   INTEGER :: JINT = 0
   CALL CALERF_r8(X, DERF, JINT)
END FUNCTION DERF
FUNCTION ERF_r4(X)
   integer, parameter :: rk = r4
   real(rk), intent(in) :: X
   real(rk) :: ERF_r4
   INTEGER :: JINT = 0
   CALL CALERF_r4(X, ERF_r4, JINT)
END FUNCTION ERF_r4
FUNCTION DERFC(X)
   integer, parameter :: rk = r8
   real(rk), intent(in) :: X
   real(rk) :: DERFC
   INTEGER :: JINT = 1
   CALL CALERF_r8(X, DERFC, JINT)
END FUNCTION DERFC
FUNCTION ERFC_r4(X)
   integer, parameter :: rk = r4
   real(rk), intent(in) :: X
   real(rk) :: ERFC_r4
   INTEGER :: JINT = 1
   CALL CALERF_r4(X, ERFC_r4, JINT)
END FUNCTION ERFC_r4
FUNCTION DERFCX(X)
   integer, parameter :: rk = r8
   real(rk), intent(in) :: X
   real(rk) :: DERFCX
   INTEGER :: JINT = 2
   CALL CALERF_r8(X, DERFCX, JINT)
END FUNCTION DERFCX
FUNCTION ERFCX_R4(X)
   integer, parameter :: rk = r4
   real(rk), intent(in) :: X
   real(rk) :: ERFCX_R4
   INTEGER :: JINT = 2
   CALL CALERF_r4(X, ERFCX_R4, JINT)
END FUNCTION ERFCX_R4
end module error_function


       SUBROUTINE W3FA13(TRIGS,RCOS)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FA13         COMPUTES TRIG FUNCTIONS
C   AUTHOR: SELA, JOE        ORG: W323       DATE: 80-11-21
C
C ABSTRACT:  COMPUTES TRIG FUNCTIONS USED IN 2.5 BY 2.5 LAT,LON
C   MAPPING ROUTINES. W3FA13 MUST BE CALLED AT LEAST ONCE BEFORE
C   CALLS TO W3FT08,W3FT09,W3FT10,W3FT11.
C
C PROGRAM HISTORY LOG:
C   80-11-21  JOE SELA
C   84-06-01  R.E.JONES   CHANGE TO VS FORTRAN
C
C USAGE:  CALL W3FA13(TRIGS,RCOS)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     N/A
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     TRIGS  ARG LIST  216 TRIG VALUES, USED BY SUBROUTINE W3FA12.
C     RCOS   ARG LIST  37 COLATITUDES USED BY SUBROUTINES W3FT09,W3FT11
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     IABS  SIN COS                                           SYSTEM
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN 77
C   MACHINE:  CRAY Y-MP8/864
C
C$$$
C
       REAL            RCOS(*)
       REAL            TRIGS(*)
C
       SAVE
C
       DATA  PI    /3.14159265358979323846/
C
         N = 144
         MODE = 3
         DRAD = 2.5*PI/180.
C
         DO 100 LAT = 2,37
           ARG = (LAT-1)*DRAD
           RCOS(LAT) = 1./SIN(ARG)
 100     CONTINUE
C
         RCOS(1) = 77777.777
         IMODE = IABS(MODE)
         NN = N
         IF (IMODE.GT.1.AND.IMODE.LT.6) NN = N/2
         ANGLE = 0.0
         DEL = (PI+PI)/FLOAT(NN)
         L = NN+NN
C
         DO 200 I = 1,L,2
           TRIGS(I) = COS(ANGLE)
           TRIGS(I+1) = SIN(ANGLE)
           ANGLE = ANGLE+DEL
 200     CONTINUE
C
         IF (IMODE.EQ.1) RETURN
         IF (IMODE.EQ.8) RETURN
         ANGLE = 0.0
         DEL = 0.5*DEL
         NH = (NN+1)/2
         L = NH+NH
         LA = NN+NN
C
         DO 300 I = 1,L,2
           TRIGS(LA+I) = COS(ANGLE)
           TRIGS(LA+I+1) = SIN(ANGLE)
           ANGLE = ANGLE+DEL
 300     CONTINUE
C
         IF (IMODE.LE.3) RETURN
         DEL = 0.5*DEL
         ANGLE = DEL
         LA = LA+NN
C
         DO 400 I = 2,NN
           TRIGS(LA+I) = 2.0*SIN(ANGLE)
           ANGLE = ANGLE+DEL
 400     CONTINUE
C
         RETURN
       END