C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.02.01/02                           *
C  *    TEST TITLE : Behavior of 3D mapping                *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C  Declare program-specific variables
      REAL       VWWNLM(4), PJVPLM(6), VWMPMT(4,4)
      REAL       PRP(3), VPD,BPD,FPD, VWCENT(3)
      INTEGER    PJTYPE

C viewtype
      INTEGER    PPARL,     PPERS
      PARAMETER (PPARL = 0, PPERS = 1)

      CALL INITGL ('06.02.01/02')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

C  Set 3D mapping parameters for PARALLEL projection:
      VWWNLM(1) = -462.27
      VWWNLM(2) = -80.95
      VWWNLM(3) = -4891.85
      VWWNLM(4) = -94.78

      PJVPLM(1) = 0.2640
      PJVPLM(2) = 0.4082
      PJVPLM(3) = 0.01339
      PJVPLM(4) = 0.7457
      PJVPLM(5) = 0.1395
      PJVPLM(6) = 0.30036

      PJTYPE = PPARL

      PRP(1) = -15.044
      PRP(2) = 1.318
      PRP(3) = 34.873
      VPD = -1.213
      BPD = -3.311
      FPD = 15.332

      CALL SETMSG ('1 2 7 8 9', '<Evaluate view mapping matrix 3> '   //
     1             'should map the corners of the view volume to '    //
     2             'the corresponding corners of the projection '     //
     3             'viewport for a PARALLEL projection.')
C subroutine TSTCOR performs pass/fail test
      CALL TSTCOR  (VWWNLM, PJVPLM, PJTYPE, PRP, VPD,BPD,FPD,
     1              VWMPMT, VWCENT)

      CALL SETMSG ('1 2 10', '<Evaluate view mapping matrix 3> '      //
     1             'should map any two points on a given projector '  //
     2             'to the same x and y values in NPC space for a '   //
     3             'PARALLEL projection.')
C subroutine TSTPRJ performs pass/fail test
      CALL TSTPRJ (PRP, VWMPMT, VWCENT)

C  Set 3D mapping parameters for PERSPECTIVE projection:
      VWWNLM(1) = -62.2236
      VWWNLM(2) = -11.39577
      VWWNLM(3) = -60.530
      VWWNLM(4) =  24.255

      PJVPLM(1) = 0.10639
      PJVPLM(2) = 0.22243
      PJVPLM(3) = 0.10012
      PJVPLM(4) = 0.15392
      PJVPLM(5) = 0.24695
      PJVPLM(6) = 0.88262

      PJTYPE = PPERS

      PRP(1) = -3.6054E-02
      PRP(2) = 2.1181E-03
      PRP(3) = 3.0569

      VPD = 0.16487
      BPD = -5.2858E-03
      FPD = 3.0531

      CALL SETMSG ('1 2 7 8 9', '<Evaluate view mapping matrix 3> '   //
     1             'should map the corners of the view volume to '    //
     2             'the corresponding corners of the projection '     //
     3             'viewport for a PERSPECTIVE projection.')
C subroutine TSTCOR performs pass/fail test
      CALL TSTCOR  (VWWNLM, PJVPLM, PJTYPE, PRP, VPD,BPD,FPD,
     1              VWMPMT, VWCENT)

      CALL SETMSG ('1 2 10', '<Evaluate view mapping matrix 3> '      //
     1             'should map any two points on a given projector '  //
     2             'to the same x and y values in NPC space for a '   //
     3             'PERSPECTIVE projection.')
C subroutine TSTPRJ performs pass/fail test
      CALL TSTPRJ (PRP, VWMPMT, VWCENT)

C  Set 3D mapping parameters for PARALLEL projection, with flat
C  viewport (ZMIN = ZMAX):
      VWWNLM(1) = -2.6073
      VWWNLM(2) = 231.673
      VWWNLM(3) = 830.654
      VWWNLM(4) = 4.74075E+4

      PJVPLM(1) = 0.30322
      PJVPLM(2) = 0.54641
      PJVPLM(3) = 0.28099
      PJVPLM(4) = 0.68383
      PJVPLM(5) = 6.0076E-03
      PJVPLM(6) = 6.0076E-03

      PJTYPE = PPARL

      PRP(1) = 3.8497
      PRP(2) = 72.490
      PRP(3) = -111.363
      VPD = -0.38069
      BPD = -0.46296
      FPD = -4.25281E-02

      CALL SETMSG ('1 2 7 8 9', '<Evaluate view mapping matrix 3> '   //
     1             'should map the corners of the view volume to '    //
     2             'the corresponding corners of a flat projection '  //
     3             'viewport for a PARALLEL projection.')
C subroutine TSTCOR performs pass/fail test
      CALL TSTCOR  (VWWNLM, PJVPLM, PJTYPE, PRP, VPD,BPD,FPD,
     1              VWMPMT, VWCENT)

      CALL SETMSG ('1 2 10', '<Evaluate view mapping matrix 3> '      //
     1             'should map any two points on a given projector '  //
     2             'to the same x and y values in NPC space for a '   //
     3             'flat projection viewport and a PARALLEL '         //
     4             'projection.')
C subroutine TSTPRJ performs pass/fail test
      CALL TSTPRJ (PRP, VWMPMT, VWCENT)

C  Set 3D mapping parameters for PERSPECTIVE projection, with a flat
C  viewport (ZMIN = ZMAX) and view volume (BPD = FPD):
      VWWNLM(1) = -13.7
      VWWNLM(2) =  71.55
      VWWNLM(3) = -51.5509
      VWWNLM(4) =  79.861

      PJVPLM(1) = 0.15580
      PJVPLM(2) = 0.537
      PJVPLM(3) = 1.7186E-03
      PJVPLM(4) = 0.3148
      PJVPLM(5) = 0.73940
      PJVPLM(6) = 0.73940

      PJTYPE = PPERS

      PRP(1) = -1.8005
      PRP(2) = -4.19006E-02
      PRP(3) =  6.3462

      VPD = 0.831
      BPD = -2.1753
      FPD = -2.1753

      CALL SETMSG ('1 2 7 8 9', '<Evaluate view mapping matrix 3> '   //
     1             'should map the corners of a flat view volume to ' //
     2             'the corresponding corners of a flat projection '  //
     3             'viewport for a PERSPECTIVE projection.')
C subroutine TSTCOR performs pass/fail test
      CALL TSTCOR  (VWWNLM, PJVPLM, PJTYPE, PRP, VPD,BPD,FPD,
     1              VWMPMT, VWCENT)

      CALL SETMSG ('1 2 10', '<Evaluate view mapping matrix 3> '      //
     1             'should map any two points on a given projector '  //
     2             'to the same x and y values in NPC space for a '   //
     3             'flat view volume, a flat projection viewport, '   //
     4             'and a PERSPECTIVE projection.')
C subroutine TSTPRJ performs pass/fail test
      CALL TSTPRJ (PRP, VWMPMT, VWCENT)

666   CONTINUE
      CALL ENDIT
      END


C
C	Calculate the first 20 terms of the
C   Fibonacci sequence and print them to stdout.
C
	ia = 1
	ib = 1
	print ia
	print ib

	do 10 k = 1, 18, 1
	ic = ia + ib
	ia = ib
	ib = ic
10	print ic

	stop


! chk_real_literal.f90 --
!     Check: does the compiler warn about overly precise constants?
!
program chk_real_literal
    implicit none

    real(kind=kind(1.0d0)) :: value
    real(kind=kind(1.0d0)) :: value_init = 1.2345678901234567890

    value = 1.2345678901234567890  ! NOTE: single-precision constant

    write( *, '(a)'      ) 'The compiler may or may not issue a warning, but the value'
    write( *, '(a)'      ) '  "1.2345678901234567890" is stored as'
    write( *, '(f25.20)' ) value
    write( *, '(/,a)'      ) 'Note: the literal value is single-precision'
end program chk_real_literal


!! R818 loop-control
!    is [ , ] do-variable = scalar-int-expr, scalar-int-expr [ , scalar-int-expr ]
!    or [ , ] WHILE ( scalar-logical-expr )
!    or [ , ] CONCURRENT forall-header
!
! from NOTE 8.10

real :: A(10), B(10)

   DO CONCURRENT (I = 1:N)
      A(I) = B(I)
   END DO

end


!	Gauss-Hermite quadrature weights.  The ith weight out of n.
real(kind=8) function gaussweight(i,n)

use gausstable
implicit none
integer,intent(in)::i,n
!	i is the point number and position is the table position.
!	n is the number of elements of th.

gaussweight=xgh(2,i+n*(n-1)/2)
return
end


c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsesrt
c
c\Description:
c  Sort the array X in the order specified by WHICH and optionally
c  apply the permutation to the columns of the matrix A.
c
c\Usage:
c  call dsesrt
c     ( WHICH, APPLY, N, X, NA, A, LDA)
c
c\Arguments
c  WHICH   Character*2.  (Input)
c          'LM' -> X is sorted into increasing order of magnitude.
c          'SM' -> X is sorted into decreasing order of magnitude.
c          'LA' -> X is sorted into increasing order of algebraic.
c          'SA' -> X is sorted into decreasing order of algebraic.
c
c  APPLY   Logical.  (Input)
c          APPLY = .TRUE.  -> apply the sorted order to A.
c          APPLY = .FALSE. -> do not apply the sorted order to A.
c
c  N       Integer.  (INPUT)
c          Dimension of the array X.
c
c  X      Double precision array of length N.  (INPUT/OUTPUT)
c          The array to be sorted.
c
c  NA      Integer.  (INPUT)
c          Number of rows of the matrix A.
c
c  A      Double precision array of length NA by N.  (INPUT/OUTPUT)
c
c  LDA     Integer.  (INPUT)
c          Leading dimension of A.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines
c     dswap  Level 1 BLAS that swaps the contents of two vectors.
c
c\Authors
c     Danny Sorensen               Phuong Vu
c     Richard Lehoucq              CRPC / Rice University
c     Dept. of Computational &     Houston, Texas
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\Revision history:
c     12/15/93: Version ' 2.1'.
c               Adapted from the sort routine in LANSO and
c               the ARPACK code dsortr
c
c\SCCS Information: @(#)
c FILE: sesrt.F   SID: 2.3   DATE OF SID: 4/19/96   RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
      subroutine dsesrt (which, apply, n, x, na, a, lda)
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      character*2 which
      logical    apply
      integer    lda, n, na
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      Double precision
     &           x(0:n-1), a(lda, 0:n-1)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer    i, igap, j
      Double precision
     &           temp
c
c     %----------------------%
c     | External Subroutines |
c     %----------------------%
c
      external   dswap
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
      igap = n / 2
c
      if (which .eq. 'SA') then
c
c        X is sorted into decreasing order of algebraic.
c
   10    continue
         if (igap .eq. 0) go to 9000
         do 30 i = igap, n-1
            j = i-igap
   20       continue
c
            if (j.lt.0) go to 30
c
            if (x(j).lt.x(j+igap)) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
               if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
            else
               go to 30
            endif
            j = j-igap
            go to 20
   30    continue
         igap = igap / 2
         go to 10
c
      else if (which .eq. 'SM') then
c
c        X is sorted into decreasing order of magnitude.
c
   40    continue
         if (igap .eq. 0) go to 9000
         do 60 i = igap, n-1
            j = i-igap
   50       continue
c
            if (j.lt.0) go to 60
c
            if (abs(x(j)).lt.abs(x(j+igap))) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
               if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
            else
               go to 60
            endif
            j = j-igap
            go to 50
   60    continue
         igap = igap / 2
         go to 40
c
      else if (which .eq. 'LA') then
c
c        X is sorted into increasing order of algebraic.
c
   70    continue
         if (igap .eq. 0) go to 9000
         do 90 i = igap, n-1
            j = i-igap
   80       continue
c
            if (j.lt.0) go to 90
c
            if (x(j).gt.x(j+igap)) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
               if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
            else
               go to 90
            endif
            j = j-igap
            go to 80
   90    continue
         igap = igap / 2
         go to 70
c
      else if (which .eq. 'LM') then
c
c        X is sorted into increasing order of magnitude.
c
  100    continue
         if (igap .eq. 0) go to 9000
         do 120 i = igap, n-1
            j = i-igap
  110       continue
c
            if (j.lt.0) go to 120
c
            if (abs(x(j)).gt.abs(x(j+igap))) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
               if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
            else
               go to 120
            endif
            j = j-igap
            go to 110
  120    continue
         igap = igap / 2
         go to 100
      end if
c
 9000 continue
      return
c
c     %---------------%
c     | End of dsesrt |
c     %---------------%
c
      end


       INTEGER FUNCTION LOCALDIM(GDIM,NP,ME)

!   GDIM = GLOBAL DIMENSION OF AN ARRAY TO BE SHEARED AMONG PROCESSORS
!   NP   = NUMBER OF PROCESSOR
!   ME   = INDEX OF THE CALLING PROCESSOR (starting from 0)
!
!   THIS FUNCTION RETURN THE NUMBER OF ELEMENTS OF THE ARRAY STORED
!   IN THE LOCAL MEMORY OF THE PROCESSOR "ME"

       IMPLICIT NONE
       INTEGER GDIM,NP,ME, R,Q

       Q = INT(GDIM/NP)
       R = MOD(GDIM,NP)

       IF((ME+1).LE.R) THEN
         LOCALDIM = Q+1
       ELSE
         LOCALDIM = Q
       END IF

       RETURN
       END


!---------------------------------------------------------------------------------------------------
!
! filename = plotting.f90
! authors = Edison Salazar
!     Pedro Guarderas
! date = 20/05/2014
!
!---------------------------------------------------------------------------------------------------

! Plotting routines with DISLIN
module plotting
!   use dislin
  implicit none

contains

!---------------------------------------------------------------------------------------------------
subroutine contour( A, m, n, xmin, xmax, sx, ymin, ymax, sy, zmin, zmax, sz, inter )
  implicit none
  integer, intent( in ) :: m, n, sx, sy, sz, inter
  double precision, intent( in ) :: A(m,n)
  real, intent( in ) :: xmin, xmax, ymin, ymax, zmin, zmax
  real :: hx, hy, hz

  hx = sngl( xmax - xmin ) / real( sx - 1 )
  hy = sngl( ymax - ymin ) / real( sy - 1 )
  hz = sngl( zmax - zmin ) / real( sz - 1 )

  call METAFL('CONS')
  call DISINI()
  call PAGERA()
  call HWFONT()

  call TITLIN('Function',2)

  call NAME('X-axis','r')
  call NAME('Y-axis','theta')
  call NAME('Z-axis','An')

  call INTAX()
  call AUTRES(m,n)
!   call AXSPOS(300,1850)
  call AX3LEN(1500,1500,1500)

  call GRAF3( xmin, xmax, xmin, hx, ymin, ymax, ymin, hy, zmin, zmax, zmin, hz )
  call CRVMAT( sngl(A), m, n, inter, inter )

  call HEIGHT(50)
  call TITLE()
  call DISFIN()

end subroutine contour

!---------------------------------------------------------------------------------------------------
subroutine surface( A, x, y, m, n, &
                    xmin, xmax, sx, ymin, ymax, sy, zmin, zmax, sz, vx, vy, vz )
  implicit none
  integer, intent( in ) :: m, n, sx, sy, sz
  character ( len = 60 ) :: tit1, tit2
  double precision, intent( in ) :: A(m,n), x(m), y(n)
  real, intent( in ) :: xmin, xmax, ymin, ymax, zmin, zmax, vx, vy, vz
  real :: hx, hy, hz

  hx = sngl( xmax - xmin ) / real( sx - 1 )
  hy = sngl( ymax - ymin ) / real( sy - 1 )
  hz = sngl( zmax - zmin ) / real( sz - 1 )

  tit1 = 'Function'
  tit2 = 'Surface'

  call SETPAG('DA4P')
  call METAFL('CONS')
  call DISINI()
  call PAGERA()
  call COMPLX()
!   call AXSPOS(10,10)
!   call AXSLEN(2500,2000)

  call NAME('X-axis','X')
  call NAME('Y-axis','Y')
  call NAME('Z-axis','Z')

  call TITLIN( tit1, 2 )
  call TITLIN( tit2, 4 )

  call VIEW3D( vx, vy, vz,'ANGLE' )
  call GRAF3D( xmin, xmax, xmin, hx, ymin, ymax, ymin, hy, zmin, zmax, zmin, hz )
  call HEIGHT(50)
  call TITLE()

  call SHDMOD('SMOOTH','SURFACE')
  call SURSHD( sngl(x), m, sngl(y), n, sngl(A) )

  call DISFIN()

end subroutine surface

end module plotting


!==========================================================================
elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction)
!==========================================================================
!
!  Calculates the Conservative Temperature at which seawater freezes.
!  The error of this fit ranges between -5e-4 K and 6e-4 K when compared
!  with the Conservative Temperature calculated from the exact in-situ
!  freezing temperature which is found by a Newton-Raphson iteration of the
!  equality of the chemical potentials of water in seawater and in ice.
!  Note that the Conservative temperature freezing temperature can be found
!  by this exact method using the function gsw_CT_freezing.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!  saturation_fraction = the saturation fraction of dissolved air in
!                        seawater
!
!  CT_freezing = Conservative Temperature at freezing of seawater [ deg C ]
!                That is, the freezing temperature expressed in
!                terms of Conservative Temperature (ITS-90).
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sso

use gsw_mod_freezing_poly_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p, saturation_fraction

real (r8) :: gsw_ct_freezing_poly

real (r8) :: p_r, sa_r, x

sa_r = sa*1e-2_r8
x = sqrt(sa_r)
p_r = p*1e-4_r8

gsw_ct_freezing_poly = c0 &
    + sa_r*(c1 + x*(c2 + x*(c3 + x*(c4 + x*(c5 + c6*x))))) &
    + p_r*(c7 + p_r*(c8 + c9*p_r)) + sa_r*p_r*(c10 + p_r*(c12 &
    + p_r*(c15 + c21*sa_r)) + sa_r*(c13 + c17*p_r + c19*sa_r) &
    + x*(c11 + p_r*(c14 + c18*p_r) + sa_r*(c16 + c20*p_r + c22*sa_r)))

! Adjust for the effects of dissolved air
gsw_ct_freezing_poly = gsw_ct_freezing_poly - saturation_fraction* &
                 (1e-3_r8)*(2.4_r8 - a*sa)*(1.0_r8 + b*(1.0_r8 - sa/gsw_sso))

return
end function


       SUBROUTINE W3FT06(ALOLA,APOLA,W1,W2,LINEAR)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FT06         CONVERT (145,37) TO (65,65) S. HEMI. GRID
C   AUTHOR: JONES,R.E.       ORG: W342       DATE: 84-06-18
C
C ABSTRACT:  CONVERT A SOUTHERN HEMISPHERE 2.5 DEGREE LAT.,LON. 145 BY
C   37 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR
C   STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. S. , THE MESH
C   LENGTH IS 381 KM. AND THE ORIENTION IS 260 DEG. W.(100E)  .
C
C PROGRAM HISTORY LOG:
C   84-06-18  R.E.JONES
C   91-07-30  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C   92-05-02  R.E.JONES   ADD SAVE
C
C USAGE:  CALL W3FT06(ALOLA,APOLA,W1,W2,LINEAR)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     ALOLA  ARG LIST  145*37 DEG 2.5 LAT,LON GRID S. HEMI.
C                      5365 POINT GRID IS TYPE 30 OR 1E HEX O.N. 84
C     LINEAR ARG LIST  1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     APOLA  ARG LIST  65*65 GRID OF SOUTHERN HEMI.
C                      4225 POINT GRID IS TYPE 28 OR 1C HEX O.N. 84
C     W1     ARG LIST  65*65 SCRATCH FIELD
C     W2     ARG LIST  65*65 SCRATCH FIELD
C            FT06F001  ERROR MESSAGE
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     ASIN   ATAN2                                            SYSTEM
C
C   REMARKS:
C
C   1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE
C   REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. IF THEY ARE
C   OVER WRITTEN BY THE USER, A WARNING MESSAGE WILL BE PRINTED
C   AND W1 AND W2 WILL BE RECOMPUTED.
C
C   2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION
C   AFTER INTERPOLATION. YOU MAY USE W3FC10 TO DO THIS.
C
C   3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED
C   OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*65
C   GRID (ABOUT 1100 POINTS).
C
C   4. YOU SHOULD USE THE CRAY VECTORIZED VERION W3FT06V ON THE CRAY
C   IT HAS 3 PARAMETERS IN THE CALL, RUNS ABOUT TIMES FASTER, USES
C   MORE MEMORY.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/864
C
C$$$
C
       REAL            ALOLA(145,37)
       REAL            APOLA(4225)
       REAL            ERAS(4)
       REAL            SAVEW1(10)
       REAL            SAVEW2(10)
       REAL            W1(4225)
       REAL            W2(4225)
C
       INTEGER         JY(4)
       INTEGER         OUT
C
       LOGICAL         LIN
C
       SAVE
C
       DATA  DEGPRD/57.2957795/
       DATA  EARTHR/6371.2/
       DATA  ISWT  /0/
       DATA  OUT   /6/
C
 4000  FORMAT ( 52H *** WARNING , W1 OR W2 SCRATCH FILES OVER WRITTEN ,,
     &          43H I WILL RESTORE THEM , BURNING UP CPU TIME,,
     &          14H IN W3FT06 ***)
C
         LIN = .FALSE.
         IF (LINEAR.EQ.1) LIN = .TRUE.
         IF  (ISWT.EQ.0)  GO TO  300
C
C        TEST TO SEE IF W1 OR W2 WAS WRITTEN OVER
C
         DO 100  KK=1,10
           IF (SAVEW1(KK).NE.W1(KK))  GO TO 200
           IF (SAVEW2(KK).NE.W2(KK))  GO TO 200
 100     CONTINUE
         GO TO 800
C
 200     CONTINUE
         WRITE (OUT,4000)
C
 300     CONTINUE
         DEG   = 2.5
         NN    = 0
         XMESH = 381.0
         GI2   = (1.86603*EARTHR) / XMESH
         GI2   = GI2 * GI2
C
C        DO LOOP 600 PUTS SUBROUTINE W3FB03 IN LINE
C
         DO  600 J=1,65
           XJ = J - 33
           XJ2 = XJ * XJ
           DO  600 I=1,65
             XI = I - 33
             R2 = XI*XI + XJ2
             IF  (R2.NE.0.0)  GO TO  400
             WLON = 0.0
             XLAT = -90.0
             GO TO  500
 400         CONTINUE
             XLONG = DEGPRD * ATAN2(XJ,XI)
             WLON = XLONG -10.0
             IF (WLON.LT.0.0)  WLON = WLON + 360.0
             XLAT = ASIN((GI2-R2)/(GI2+R2))*DEGPRD
             XLAT = -XLAT
 500         CONTINUE
             XLAT = XLAT + 90.0
             IF  (WLON.GT.360.0)  WLON = WLON - 360.0
             IF  (WLON.LT.0.0)    WLON = WLON + 360.0
             NN = NN + 1
             W1(NN) = ( 360.0 - WLON ) / DEG + 1.0
             W2(NN) = XLAT / DEG + 1.0
  600      CONTINUE
C
         DO 700  KK=1,10
           SAVEW1(KK)=W1(KK)
           SAVEW2(KK)=W2(KK)
 700     CONTINUE
C
           ISWT = 1
C
 800     CONTINUE
C
         DO  1900  KK=1,4225
           I = W1(KK)
           J = W2(KK)
           FI = I
           FJ = J
           XDELI = W1(KK) - FI
           XDELJ = W2(KK) - FJ
           IP1 = I + 1
           JY(3) = J + 1
           JY(2) = J
           IF (LIN)  GO TO  900
           IP2 = I + 2
           IM1 = I - 1
           JY(4) = J + 2
           JY(1) = J - 1
           XI2TM = XDELI*(XDELI-1.)*.25
           XJ2TM = XDELJ*(XDELJ-1.)*.25
 900     CONTINUE
         IF ((I.LT.2).OR.(J.LT.2)) GO TO 1000
         IF ((I.GT.142).OR.(J.GT.34)) GO TO  1000
C     QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1500
         GO TO  1500
C
 1000    CONTINUE
         IF (I.EQ.1) GO TO 1100
         IF (I.EQ.144) GO TO 1200
         IP2 = I+2
         IM1 = I-1
         GO TO  1300
C
 1100    CONTINUE
         IP2 = 3
         IM1 = 144
         GO TO  1300
C
 1200    CONTINUE
         IP2 = 2
         IM1 = 143
C
 1300    CONTINUE
         IP1 = I + 1
         IF (LIN)  GO TO  1400
         IF ((J.LT.2).OR.(J.GE.36))  XJ2TM=0.
C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
         IF (IP2.LT.1) IP2 = 1
         IF (IM1.LT.1) IM1 = 1
         IF (IP2.GT.145) IP2 = 145
         IF (IM1.GT.145) IM1 = 145
C
 1400    CONTINUE
C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
         IF (I.LT.1) I = 1
         IF (IP1.LT.1) IP1 = 1
         IF (I.GT.145) I = 145
         IF (IP1.GT.145) IP1 = 145
C
 1500    CONTINUE
C
         IF (.NOT.LIN)  GO TO  1700
C
C        LINEAR INTERPOLATION
C
          DO 1600 K = 2,3
           J1 = JY(K)
           IF  (J1.LT.1)  J1=1
           IF  (J1.GT.37) J1=37
           ERAS(K) = (ALOLA(IP1,J1) - ALOLA(I,J1)) * XDELI + ALOLA(I,J1)
 1600    CONTINUE
C
         APOLA(KK) = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ
         GO TO  1900
C
 1700    CONTINUE
C
C        QUADRATIC INTERPOLATION
C
         DO 1800  K = 1,4
           J1 = JY(K)
C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
           IF (J1.LT.1) J1=1
           IF (J1.GT.37) J1=37
           ERAS(K)=(ALOLA(IP1,J1)-ALOLA(I,J1))*XDELI+ALOLA(I,J1)+
     &             (ALOLA(IM1,J1)-ALOLA(I,J1)-ALOLA(IP1,J1)+
     &              ALOLA(IP2,J1))*XI2TM
 1800    CONTINUE
C
         APOLA(KK) = ERAS(2)+(ERAS(3)-ERAS(2))*XDELJ+(ERAS(1)-
     &               ERAS(2)-ERAS(3)+ERAS(4))*XJ2TM
C
 1900    CONTINUE
C
C        SET POLE POINT, WMO STANDARD FOR U OR V
C
         APOLA(2113) = ALOLA(73,1)
C
         RETURN
       END


bil = 4*Pgas*cgs_mhydr*cgs_stef*miu*(T - Trad)*(4*Trad**4*cgs_boltz*F(1, &
      2)/(cgs_c**2*cgs_mel) + (T + Trad)*(T**2 + Trad**2)*F(1, 1))/(T* &
      cgs_boltz*heat) - 1
bil_T = 4*Pgas*cgs_mhydr*cgs_stef*miu*(T**5*cgs_c**2*cgs_mel*F(2, 1) + 3 &
      *T**4*cgs_c**2*cgs_mel*F(1, 1) + 4*T**2*Trad**4*cgs_boltz*F(2, 2 &
      ) - 4*T*Trad**5*cgs_boltz*F(2, 2) - T*Trad**4*cgs_c**2*cgs_mel*F( &
      2, 1) + 4*Trad**5*cgs_boltz*F(1, 2) + Trad**4*cgs_c**2*cgs_mel*F( &
      1, 1))/(T**2*cgs_boltz*cgs_c**2*cgs_mel*heat)