      subroutine ris1d(ecs,xs,ms,
     $     nxs,eigval,eigfun,nauto)
      implicit none
      integer nmaxs1
      integer*4 nxs,i,j,k,ix,l,i1,j1,ii
      integer ierr,nauto
      double precision ecs(nxs),xs(nxs),m0,
     $     ms(nxs),eigfun(nxs*nauto),zzz(nxs-2,nxs-2),
     $     a(nxs-2),b(nxs-2),hbar,q,deltai(nxs),eigval(nauto),
     $     di,dip,bi,xs2(nxs),ms2(nxs)
      hbar=1.05459e-34
      q=1.60219e-19
      m0=9.1095e-31

      do i=1,nxs*nauto
         eigfun(i)=0
      enddo

      do i=1,nxs
         xs2(i)=xs(i)*1e-9
         ms2(i)=ms(i)*m0
      enddo

c$$$      open(unit=67,file='BC2.out',status='unknown')
c$$$      do i=1,nxs
c$$$         write(67,*) xs2(i),ecs(i)
c$$$      enddo
c$$$      close(67)

c     inizializzo i deltai

      do i=1,nxs
         if (i.eq.1) then
            deltai(i)=sqrt(2/(xs2(i+1)-xs2(i)))
         elseif (i.eq.nxs) then
            deltai(i)=sqrt(2/(xs2(i)-xs2(i-1)))
         else
            deltai(i)=sqrt(2/(xs2(i+1)-xs2(i-1)))
         endif
      enddo

      do i=1,nxs
         if ((i.ne.1).and.(i.ne.nxs)) then
            a(i-1)=hbar**2/(2*q)*
     $           (1/((ms2(i))
     $           *(xs2(i+1)-xs2(i)))+
     $           1/((ms2(i-1))
     $           *(xs2(i)-xs2(i-1))))
     $           +0.5*(xs2(i+1)-xs2(i-1))*ecs(i)
            a(i-1)=a(i-1)*2/(xs2(i+1)-xs2(i-1))

            if (i.ne.nxs-1) then

               b(i)=-hbar**2/(2*q*(
     $              ms2(i))
     $              *(xs2(i+1)-xs2(i)))
               di=deltai(i)
               dip=deltai(i+1)
               bi=b(i)
               b(i)=deltai(i)*b(i)*deltai(i+1)
            endif
         endif
      enddo

c$$$      open(unit=67,file='a10.out',status='unknown')
c$$$      open(unit=68,file='b10.out',status='unknown')
c$$$      do i=1,nxs-2
c$$$         write(67,*) a(i)
c$$$         write(68,*) b(i)
c$$$      enddo
c$$$      close(67)
c$$$      close(68)

c     rendo identica la matrice iniziale

      do i1=1,nxs-2
         do j1=1,nxs-2
            if(i1.eq.j1) then
               zzz(i1,j1)=1
            else
               zzz(i1,j1)=0
            endif
         enddo
      enddo

      ierr=0
      b(1)=0
      call imtql2(nxs-2,nxs-2,a,b,zzz,ierr)
      if (ierr.ne.0) then
         print*,'IMTQL2 ha dato un errore',ierr
         pause
      endif

      do l=1,nauto
         do i=1,nxs
            if ((i.ne.1).and.(i.ne.nxs)) then
               eigfun(i+(l-1)*nxs)=zzz(i-1,l)
     $              *sqrt(2/(xs2(i+1)-xs2(i-1)))
            else
               eigfun(i+(l-1)*nxs)=0
            endif
         enddo
         eigval(l)=a(l)
      enddo

c$$$      open(unit=67,file='eigve.out',status='unknown')
c$$$      do i=1,nxs
c$$$         write(67,*) xs2(i),eigfun(i+nxs)
c$$$      enddo
c$$$      close(67)

      return
      end

      subroutine imtql2(nm,n,d,e,z,ierr)
c
      integer*4 i,j,k,l,m,n,ii,nm,mml
      integer ierr
      double precision d(n),e(n),z(nm,n)
      double precision b,c,f,g,p,r,s,tst1,tst2,pythag
c
c     this subroutine is a translation of the algol procedure imtql2,
c     num. math. 12, 377-383(1968) by martin and wilkinson,
c     as modified in num. math. 15, 450(1970) by dubrulle.
c     handbook for auto. comp., vol.ii-linear algebra, 241-248(1971).
c
c     this subroutine finds the eigenvalues and eigenvectors
c     of a symmetric tridiagonal matrix by the implicit ql method.
c     the eigenvectors of a full symmetric matrix can also
c     be found if  tred2  has been used to reduce this
c     full matrix to tridiagonal form.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c        z contains the transformation matrix produced in the
c          reduction by  tred2, if performed.  if the eigenvectors
c          of the tridiagonal matrix are desired, z must contain
c          the identity matrix.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,ierr-1.
c
c        e has been destroyed.
c
c        z contains orthonormal eigenvectors of the symmetric
c          tridiagonal (or full) matrix.  if an error exit is made,
c          z contains the eigenvectors associated with the stored
c          eigenvalues.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      e(n) = 0.0d0
c
      do 240 l = 1, n
         j = 0
c     .......... look for small sub-diagonal element ..........
  105    do 110 m = l, n
            if (m .eq. n) go to 120
            tst1 = dabs(d(m)) + dabs(d(m+1))
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
  110    continue
c
  120    p = d(l)
         if (m .eq. l) go to 240
         if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         g = (d(l+1) - p) / (2.0d0 * e(l))
         r = pythag(g,1.0d0)
         g = d(m) - p + e(l) / (g + dsign(r,g))
         s = 1.0d0
         c = 1.0d0
         p = 0.0d0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            i = m - ii
            f = s * e(i)
            b = c * e(i)
            r = pythag(f,g)
            e(i+1) = r
            if (r .eq. 0.0d0) go to 210
            s = f / r
            c = g / r
            g = d(i+1) - p
            r = (d(i) - g) * s + 2.0d0 * c * b
            p = s * r
            d(i+1) = g + p
            g = c * r - b
c     .......... form vector ..........
            do 180 k = 1, n
               f = z(k,i+1)
               z(k,i+1) = s * z(k,i) + c * f
               z(k,i) = c * z(k,i) - s * f
  180       continue
c
  200    continue
c
         d(l) = d(l) - p
         e(l) = g
         e(m) = 0.0d0
         go to 105
c     .......... recover from underflow ..........
  210    d(i+1) = d(i+1) - p
         e(m) = 0.0d0
         go to 105
  240 continue
c     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
         i = ii - 1
         k = i
         p = d(i)
c
         do 260 j = ii, n
            if (d(j) .ge. p) go to 260
            k = j
            p = d(j)
  260    continue
c
         if (k .eq. i) go to 300
         d(k) = d(i)
         d(i) = p
c
         do 280 j = 1, n
            p = z(j,i)
            z(j,i) = z(j,k)
            z(j,k) = p
  280    continue
c
  300 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end

      double precision function pythag(a,b)
      double precision a,b
c
c     finds dsqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 pythag = p
      return
      end


C
C $Id: haproj.f,v 1.4 2008-09-18 00:42:16 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE HAPROJ (DLAT,DLON,UVAL,VVAL)
C
        DOUBLE PRECISION DLAT,DLON,UVAL,VVAL
C
C The subroutine HAPROJ implements a closed form of the Hammer
C projection, using formulas identical to those given on various Web
C sites.
C
C DLAT and DLON are input values of latitude and longitude, in radians.
C UVAL and VVAL are output values of U and V, in the projection plane.
C
C The common block MAPCM0 contains mathematical constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C Local variable.
C
        DOUBLE PRECISION TVAL
C
C Do the math.
C
        TVAL=SQRT(1.D0+COS(DLAT)*COS(.5D0*DLON))
C
        UVAL=TSRT*COS(DLAT)*SIN(.5D0*DLON)/TVAL
        VVAL=SROT*SIN(DLAT)/TVAL
C
        RETURN
C
      END


	SUBROUTINE GQTOI  ( np, xm, ym, xi, yi, iret )
C************************************************************************
C* GQTOI								*
C* 									*
C* This subroutine converts points in the graph coordinate system or	*
C* rotated grid lat/lon coordinates to the grid linear intermediate	*
C* coordinate system.							*
C* 									*
C* GQTOI  ( NP, XM, YM, XI, YI, IRET )					*
C* 									*
C* Input parameters:							*
C*	NP		INTEGER		Number of points		*
C* 	XM (NP)		REAL		X map coordinates		*
C*	YM (NP)		REAL		Y map coordinates		*
C*									*
C* Output parameters:							*
C*	XI (NP)		REAL		X linear coordinates		*
C* 	YI (NP)		REAL		Y linear coordinates		*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/GSFC	6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	6/86	Corrected names of scaling terms for	*
C*				graph transformations			*
C* M. desJardins/GSFC	10/86	Added polar coordinate system		*
C* M. desJardins/GSFC	 2/87	Corrected polar coord when graph not set*
C* M. desJardins/GSFC	 1/88	Missing data fix			*
C* M. desJardins/GSFC	 6/88	Adapted from GMTOG			*
C* K. Brill/EMC		 3/96	Made from GMTOI for general rotated proj*
C* K. Brill/EMC		 6/98	Rotate L coordinates for WAFS grids	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERROR.PRM'
	INCLUDE		'XYDEF.CMN'
C*
	REAL		xm (*), ym (*), xi (*), yi (*)
C*
C-------------------------------------------------------------------------
C*	Transform from map to linear intermediate grid coordinates.
C*	Select code for current mode.
C
	IF  ( ( igmode .eq. 1 ) .and. ( mgset ) ) THEN
C*
	    IF  ( mgclas .eq. MCCYL ) THEN
C*
		IF ( jtmtyp .eq. 1 .or. jtmtyp .eq. 3 ) THEN
		    xang2 = gangr2
		ELSE
		    xang2 = 0.0
		END IF
	    	CALL GCYLML ( mgproj, mgsppj, np, xm, ym, gangr1,
     +			      xang2, gangr3, gscmcd, grvrxy,
     +			      xi, yi, iret )
C
C*		Rotate L coordinates.
C
		IF ( rotagl ) CALL GROTTL ( 'G', +1, np, xi, yi, ier )
C*
	      ELSE IF  ( mgclas .eq. MCAZM ) THEN
		IF ( jtmtyp .eq. 1 ) THEN
		    xang2 = gangr2 + HALFPI
		ELSE
		    xang2 = 0.0
		END IF
 	    	CALL GAZMML ( mgproj, mgsppj, np, xm, ym, gangr1,
     +			      xang2, gangr3, gazsav, xi, yi, iret )
C*
	      ELSE IF  ( mgclas .eq. MCCON ) THEN
		IF ( jtmtyp .eq. 1 ) THEN
		    xang2 = gangr2
		ELSE
		    xang2 = -HALFPI
		END IF
	    	CALL GCONML ( mgproj, mgsppj, np, xm, ym, gangr1,
     +			      xang2, gangr3, gconcn, xi, yi, iret )
C*
	      ELSE
	    	iret = NIPROJ
	    END IF
C*
	  ELSE IF  ( ( igmode .eq. 2 ) .and. ( ggset ) )THEN
C
C*	    Check for special case of translating to and from polar coordinates.
C*	    The map coordinates are transformed to/from r, theta if
C*	    necessary to correspond to the grid coordinate definition.
C
	    IF  ( ( jgxtyp .eq. 5 ) .and. ( jxtyp .ne. 5 ) .and.
     +					gset )  THEN
		DO  i = 1, np
		    CALL XYTORT ( xm (i), ym (i), r, theta, ier )
		    xm (i) = r
		    ym (i) = theta
		END DO
C
	      ELSE IF ( (jgxtyp .ne. 5) .and. (jxtyp .eq. 5) ) THEN
		DO  i = 1, np
		    CALL RTTOXY ( xm (i), ym (i), x, y, ier )
		    xm (i) = x
		    ym (i) = y
		END DO
	    END IF
C
C*	    Transform graph coordinates to linear intermediate coords.
C
	    jx = jgxtyp
	    jy = jgytyp
	    IF ( jx .eq. 5 ) jx = 1
	    IF ( jy .eq. 5 ) jy = 1
	    CALL GGRFML ( jx, jy, np, xm, ym, gglx1, gglx0,
     +			  ggly1, ggly0, xi, yi, iret )
	  ELSE
	    iret = NIMODE
	END IF
C*
	RETURN
	END


Real Function width(dmass)
  Save
  avmass = 0.938868
  pimass = 0.137265
  aux = 0.25*(dmass**2-avmass**2-pimass**2)**2 - (avmass*pimass)**2
  If (aux>0.) Then
     qavail = sqrt(aux/dmass**2)
  Else
     qavail = 1.E-06
  End If
  width = 0.47*qavail**3/(pimass**2*(1.+0.6*(qavail/pimass)**2))
  Return
End Function width


subroutine BALL (PES, RHA)
  use simsphere_mod
  implicit none

!        INCLUDE 'modvars.h'

!/ 24th March 1995 -- RST is always unscaled in this subroutine.

!       A BRAND NEW ROUTINE TO GET FCO2 USING PHOTO MODEL
!
!       PAR      >> PAR IN MOL UNITS
!       RRTOT    >> TOTAL RESISTANCE FOR CO2 DIFFUSION IN MOL UNITS
!       RAIR     >> SURFACE LAYER RESISTANCE
!       FCO2     >> CO2 FLUX (EITHER SCALED PER LEAF OR TOTAL)
!       CII      >> INTERNAL LEAF CO2 IN PPM

!       THE FOLLOWING ARE FROM THE TWO FARQUHAR PAPERS AND THE
!       "NOTE ON CARBON FIXATION MODELING" CONTAINS THE CURRENT
!       PARAMETERIZATIONS FOR CCOMP, KO, KC, WR.  MOST OF THE
!       PARAMETERS ARE NOW SET ACCORDING TO COLLATZ, BALL, BERRY.
!
!       AKC >> MM CONSTANT FOR CO2
!       AKO >> MM COMNSTANT FOR O2
!       OXY >> OXYGEN CONCENTRATION IN CHLOROPLASTS
!       VCMAX >> MAXIMUM CARBOXYLATION RATE
!       ALPI >> QUANTUM YEILD (PHOTONS PER CO2)
!       CCOMP >> CO2 COMPENSATION POINT
!       FCO2 >> CARBON EXCHANGE RATE
!       RESP >> DARK RESPIRATION
!       CII >> INTERNAL CO2 CONCENTRATION
!       WE >> RUBISCO LIMITED PHOTOSYNTHESIS
!       WR >> RUBP REGENERATION LIMITED PHOTOSYNTHESIS
!       VC >> CARBON EXCAHNGE IN ABSENSE OF PHOTORESPIRATION
!       PARQ >> PAR WHEN WR = WE FOR GIVEN CONDITIONS
!       TAU >> CO2/O2 SPECIFICITY RATIO
!
!       CSS >>>    LEAF SFC CO2 CONCENTRATION
!       GS  >>>    STOMATAL CONDUCTANCE

!
!       CARBON FLUX AND RESISTANCES SHOULD BE PER UNIT LEAF AREA
!       TO GET PSHYSIOLOGICAL CII
!
  character(len=7) :: LIMIT

  real :: PES, RHA, PAR, RAIR, RRTOT, AKC, TAU, AKO, VCMAX, RESP, CCOMP
  real :: AKC0, AKO0, OXY, VCMAX0, ALPI, RESP0, TAU0, AJPAR, AJMAX, AMPAR
  real :: CII, WE, AJ, WR, WS, VC, PARQ
  real :: AAA, BBB, CCC, GS, QBND, RHL, CSS

  RST = RST * XLAI / PES
  RAF = RAF * XLAI / PES  ! Unscaled
  FCO2 = FCO2 * PES / XLAI / FRVEG  ! Unscaled

!
!       PAR IN MOL UNITS
!
  PAR = ((SOL/2)*4.57)*1E-6      ! IN MOL UNITS

  RAIR = RHA + RZASCR
  RRTOT = 1.32 * RAF + 1.66*RST + RAIR
  RRTOT = RRTOT / 40.             ! IN MOL UNITS

!	SET SOME PARAMTERS  PhotoSyn Model (NOW READ IN START)

  AKC0 = 3.0E-4
  AKO0 = 0.300
  OXY = 0.209
  VCMAX0 =  2.0E-4 !COLLATZ  !7.5E-5    DATA 1992
  ALPI = 12
  RESP0 = 3.0*1E-6
  TAU0 = 2600
  AJPAR = 380E-6

  AMPAR = 9.0   ! Conductance Model

!
!       CORRECT KINEMATIC PROPERTIES TO TEMPERATURE
!	SEE COLLATZ, BALL, BERRY, FARQUHAR
!
  AKC = AKC0*(2.1**((TF-298)/10))
  TAU = TAU0*(0.57**((TF-298)/10))
  AKO = AKO0*(1.2**((TF-298)/10))
  VCMAX = VCMAX0*(2.4**((TF-298)/10))
  RESP = RESP0*(2.0**((TF-298)/10))
  CCOMP = OXY/(2*TAU)
  AJMAX = AJPAR * (1. + 0.0409*(TF-303.) - 1.54E-3 * ((TF-303.)**2) - 9.42E-5 * ((TF-303.)**3))

!
!	CORRECT RESP INHIBITION AT HIGH TEMPERATURES
!       FROMM COLLATZ, BALL, BERRY
!

  RESP = RESP*1/(1+EXP((1.3*(TF-328))))

!
!       DO INTERATIONS TO GET CII STABLE WHEN CONDITIONS CHANGING
!       RAPIDLY.
!

20      CONTINUE

!
!	GUESS AT CI
!

  CI = CO - FCO2 * RRTOT
  CII = CO - FCO2 * RRTOT  ! Previous Value

  if (CI < 0) CI = 220*1E-6

!
!       CALCULATE NEW RUBISCO AND RUBP LIMITED RATES
!

  WE = VCMAX*CI/(CI + AKC*(1+(OXY/AKO)))
  AJ = AJMAX * PAR / (PAR + 2.1 * AJMAX)
  WR = AJ * CI / (4.5 * CI + 10.5 * CCOMP)
  WS = VCMAX / 2

!
!       DETERMINE THE FACTOR WHICH IS LIMITIING
!

  IF (WE <= WR .and. WE <= WS) THEN
    LIMIT = 'RUBISCO'
  ELSE IF (WR < WE .and. WR < WS) THEN
    LIMIT = 'E TRANS'
  ELSE
    LIMIT = 'SINK'
  END IF

!
!       SET CARBOXYLATION RATE TO THE LIMITING FACTOR
!

  VC = MIN(WE,WR,WS)
  PARQ = WE * (ALPI*(1+(2*CCOMP/CI)))

!
!       CO2 FLUX
!

  FCO2 = VC*(1 - CCOMP/CI) - RESP
  IF (CCOMP > CI) FCO2 = - RESP

!
!       BALL BERRY STOMATAL CONDUCTANCE MODEL
!

!         gs = AMPAR * fco2 * (rhl)/css + 0.01  !IN MOL UNITS

!
!       ESITIMATE OF Gs ---- RECHECK THIS: THERE MAY BE A PROBLEM
!       USING 1.32 FOR WATER VAPOR.
!

  AAA = CI
  BBB = CO / (RAF * 1.32 + RAIR) - AMPAR * FCO2
  CCC = -AMPAR * FCO2 * QAF / (QSTF * RAF)

!
!       SOLUTION IF NO RELATIVE HUMIDITY DEPENDANCE
!	Following 2 statements ....

!	 BBB = CO/(RAF * 1.32 + RAIR)
!        CCC = - AMPAR * FCO2

  IF (BBB**2 < 4*AAA*CCC) THEN
    RST = RCUT
  ELSE
    GS = (-BBB + SQRT(BBB**2 - 4*AAA*CCC))/(2*AAA)
    GS = GS / 40.0    !MKS UNITS
!    IF (.not. eq(GS,0.0)) RS = 1. / GS  ! Checks
!    IF (eq(GS,0.0)) RS = 500.0     ! -"-
    if (eq(gs,0.0)) then
      rs = 500.0
    else
      rs = 1.0 / gs
    end if
    RST = RS * RCUT / ( RS + RCUT )
    RRTOT = 1.32 * RAF + 1.66 * RST + RAIR
    RRTOT = RRTOT / 40.0      ! Mole units

    CI = CO - RRTOT * FCO2

!
!	CHECK IF CI IS CONVERGING
!

    IF (ABS(1 - CI/CII) > 0.05) GOTO 20

  END IF

  IF (FCO2 < 0.0) RST = RCUT

!
!	SCALE THE RESISTANCE AND CO2 FLUX
!	Not Used in any equations -- just for output

  QBND = (QSTF/RST + QAF/RAF) * (1/RAF + 1/RST)**(-1)
! Humidity at leaf surface or leaf boundary layer
  RHL = QBND/QSTF  !  RH at Leaf Surface

  CCAN = (CI/(RST*1.66 + RAF*1.32) + CO/(RAIR))*(1/(RST*1.66 + RAF*1.32) + 1/RAIR)**(-1) ! CO2 in canopy
  CSS = FCO2 * RAF * 1.66 + CCAN    ! CO2 at leaf surface

  RAF = RAF * PES / XLAI   ! Scaling Back
  RST = RST * PES / XLAI
  FCO2 = FCO2 * XLAI / PES * FRVEG

  return
end


      subroutine fitp(x,px,w,Ntraj,dpx,err)
      implicit real*8(a-h,o-z)

      integer*4,intent(IN) :: Ntraj
      real*8, intent(IN)   :: px(Ntraj), w(Ntraj),x(Ntraj)
      real*8, intent(OUT)  :: dpx(Ntraj),err
      real*8 :: f(4),s(4,4),c(4,1)

      c = 0d0
      s = 0d0
      nb = 4

      do i=1,Ntraj
        f=(/x(i),x(i)**2,x(i)**3,1d0/)
        c(1,1) = c(1,1)+px(i)*f(1)*w(i)
        c(2,1) = c(2,1)+px(i)*f(2)*w(i)
        c(3,1) = c(3,1)+f(3)*px(i)*w(i)
        c(4,1) = c(4,1)+f(4)*px(i)*w(i)
      enddo

      do m=1,nb
        do n=1,nb
          do i=1,Ntraj
            f=(/x(i),x(i)**2,x(i)**3,1d0/)
            s(m,n)=w(i)*f(m)*f(n)+s(m,n)
          end do
        end do
      end do

! calculate matrix c(t)
        call DPOSV('U',nb,1,s,nb,c,nb,INFO)
        if(INFO/=0) then
        print *, "info=",info
        print *, "polynomial fitting : matrix fails"
        stop
        end if
c     check the error of poly-fit
      call errp(ntraj,px,x,c,err)

! the momentum operator r=cf
        do i=1,Ntraj
          dpx(i) = c(1,1)+2d0*c(2,1)*x(i)+c(3,1)*3d0*x(i)**2
c     &             py(i)*(c(1,2)+2d0*c(3,2)*x(i)+c(5,2)*y(i))/am2
c          dpy(i) = px(i)*(c(2,1)+2d0*c(4,1)*y(i)+c(5,1)*x(i))/am1+
c     &             py(i)*(c(2,2)+2d0*c(4,2)*y(i)+c(5,2)*x(i))/am2
! calculate quantum potential
c          qp(i) = (c(1,1)+2d0*c(2,1)*x(i)+c(3,1)*3d0*x(i)**2)/2d0/am1
c     &            (c(2,2)+2d0*c(4,2)*y(i)+c(5,2)*x(i))/2d0/am2
c          qfx(i) = -(2d0*c(2,1)+6d0*x(i)*c(3,1))/2d0/am1
c     qfy(i) = -(c(5,1)/2d0/am1+c(4,2)/am2)
        enddo

      return
      end subroutine

c     --------------------------------
c     check the error of poly-fit of p
c     --------------------------------
      subroutine errp(nt,p,x,c,err)
      implicit real*8(a-h,o-z)

      integer*4, intent(in)  :: nt
      real*8,    intent(in)  :: p(nt),x(nt),c(4,1)
      real*8,    intent(out) :: err

      common/smaple/xmin,xmax,dx

      err = 0d0
      do i=1,nt
        pfit = c(1,1)*x(i)+c(2,1)*x(i)**2+c(3,1)*x(i)**3+c(4,1)
        err = err+(p(i)-pfit)**2*dx
      enddo

      return
      end subroutine


module mod_cheb
!=============================================================================
   use mod_prec
   use mod_field,  only: field, set_level
   use mod_io,     only: set_arr
   use mod_params, only: tables_dir, R_max, nx, ny, min_m, max_m

   implicit none
!=============================================================================
   private

   ! radial points
   real(rp), allocatable, protected, public :: Rvec
   real(rp), allocatable, protected, public :: Rarr

   ! subroutines
   public :: cheb_init, compute_DR, cheb_filter, cheb_test

   public : cheb_real_to_coef

   interface compute_DR
      module procedure compute_DR_arr, compute_DR_field
   end interface

   ! Chebyshev matrices
   real(rp), dimension(nx,nx) :: D_cheb(:,:)
   real(rp), dimension(nx,nx) :: to_cheb(:,:)
   real(rp), dimension(nx,nx) :: to_real(:,:)

   ! filter array
   real(rp), dimension(nx) :: filter_arr(:)
!=============================================================================
contains
!=============================================================================
   subroutine cheb_init()
      integer :: j

      call set_arr('cheb_pts.txt', nx,  Rvec)
      call set_arr('cheb_D.txt',nx,nx,D_cheb)

      call set_arr('real_to_cheb.txt',nx,nx,to_cheb)
      call set_arr('cheb_to_real.txt',nx,nx,to_real)

      D_cheb = (2.0_rp/R_max) * D_cheb

      Rvec = (R_max/2.0_rp) * (Rvec + 1.0_rp)

      do j=1,ny
         Rarr(:,j) = Rvec
      end do

      do j=1,nx
         filter_arr(j) = exp(-40.0_rp*(real(j-1,rp)/real(nx-1,rp))**16)
      end do
   end subroutine cheb_init
!=============================================================================
   subroutine cheb_real_to_coef(m_ang,vals,coefs)
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: coefs

      integer(ip) :: i,j

      coefs(:,:,m_ang) = 0.0_rp

      do i=1,nx
      do j=1,nx
         coefs(i,:,m_ang) = coefs(i,:,m_ang) + to_cheb(i,j)*vals(j,:,m_ang)
      end do
      end do
   end subroutine cheb_real_to_coef
!=============================================================================
   subroutine cheb_coef_to_real(m_ang,vals,coefs)
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: coefs
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: vals

      integer(ip) :: i,j

      vals(:,:,m_ang) = 0.0_rp

      do i=1,nx
      do j=1,nx
         vals(i,:,m_ang) = vals(i,:,m_ang) + to_real(i,j)*coefs(j,:,m_ang)
      end do
      end do
   end subroutine cheb_coef_to_real
!=============================================================================
   subroutine compute_DR_arr(m_ang,vals,D_vals)
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: D_vals
      integer(ip) :: i, j

      D_vals(:,:,m_ang) = 0

      do j=1,nx
      do i=1,nx
         D_vals(i,:,m_ang) = D_vals(i,:,m_ang) + (D_cheb(i,j) * vals(j,:,m_ang))
      end do
      end do
   end subroutine compute_DR_arr
!=============================================================================
   subroutine compute_DR_field(step,m_ang,f)
      integer(ip), intent(in) :: step, m_ang
      type(field), intent(inout) :: f

      call set_level(step,m_ang,f)

      call compute_DR_arr(m_ang, f%level, f%DR)

   end subroutine compute_DR_field
!=============================================================================
! Low pass filter. A smooth filter appears to help prevent Gibbs-like ringing
!=============================================================================
   subroutine cheb_filter(m_ang, f)
      integer(ip), intent(in) :: m_ang
      type(field), intent(inout) :: f

      integer(ip) :: i

      call cheb_real_to_coef(m_ang,f%np1,f%coefs_cheb)

      do i=1,nx
         f%coefs_cheb(i,:,m_ang) = filter_arr(i)*f%coefs_cheb(i,:,m_ang)
      end do

      call cheb_coef_to_real(m_ang,f%coefs_cheb,f%np1)
   end subroutine cheb_filter
!=============================================================================
   subroutine cheb_test()
      complex(rp), dimension(nx,ny,min_m:max_m) :: vals, DR_vals, computed_DR_vals
      integer(ip) :: i

      do i=1,nx
         vals(i,:,:) = sin(Rvec(i))
         DR_vals(i,:,:) = cos(Rvec(i))
      end do

      call compute_DR(0_ip, vals, computed_DR_vals)

      do i=1,nx
         write (*,*) computed_DR_vals(i,:,0_ip) - DR_vals(i,:,0_ip)
      end do

   end subroutine cheb_test
!=============================================================================
end module mod_cheb


	subroutine sig_vals(s1,t1,p1,s2,t2,p2,sig1,sig2)
ccc
ccc
ccc
ccc	DESCRIPTION :	Computes the sigma values of two neighbouring
ccc			bottles w.r.t. the mid pressure
ccc
ccc	PRECISION :	Double
ccc
ccc	INPUT :		s1,s2		bottle salinities
ccc			t1,t2		bottle in situ temperatures
ccc			p1,p2		bottle pressures
ccc
ccc	OUTPUT :	sig1,sig2	bottle potential density values
ccc
ccc	UNITS :		salinity	psu (IPSS-78)
ccc			temperature	degrees C (IPTS-68)
ccc			pressure	db
ccc			density		kg m-3
ccc
ccc
ccc	AUTHOR :	David Jackett
ccc
ccc	CREATED :	June 1993
ccc
ccc	REVISION :	1.1		30/6/93
ccc
ccc
ccc

	implicit double precision (a-h,o-z)

	pmid = (p1+p2)/2.0

	sd = svan(s1,theta(s1,t1,p1,pmid),pmid,sig1)

	sd = svan(s2,theta(s2,t2,p2,pmid),pmid,sig2)

	return
	end


Subroutine bbkaon(ic, srt, px, py, pz, ana, plx, ply, plz, ala, pkx, pky, pkz, icou1)
  Common /input1/masspr, massta, iseed, iavoid, dt
  Common /rndf77/nseed
  Save
  pi = 3.1415962
  icou1 = 0
  aka = 0.498
  ala = 1.116
  If (ic==2 .Or. ic==4) ala = 1.197
  ana = 0.939
  If (ic>2) Then
    dmax = srt - aka - ala - 0.02
    dm1 = rmass(dmax, iseed)
    ana = dm1
  End If
  t1 = aka + ana + ala
  t2 = ana + ala - aka
  If (srt<=t1) Then
    icou1 = -1
    Return
  End If
  pmax = sqrt((srt**2-t1**2)*(srt**2-t2**2))/(2.*srt)
  If (pmax==0.) pmax = 1.E-09
  ntry = 0
  1 pk = pmax*ranart(nseed)
  ntry = ntry + 1
  prob = fkaon(pk, pmax)
  If ((prob<ranart(nseed)) .And. (ntry<=40)) Goto 1
  cs = 1. - 2.*ranart(nseed)
  ss = sqrt(1.-cs**2)
  fai = 2.*3.14*ranart(nseed)
  pkx = pk*ss*cos(fai)
  pky = pk*ss*sin(fai)
  pkz = pk*cs
  ek = sqrt(aka**2+pk**2)
  eln = srt - ek
  If (eln<=0) Then
    icou1 = -1
    Return
  End If
  bx = -pkx/eln
  by = -pky/eln
  bz = -pkz/eln
  scheck = 1. - bx**2 - by**2 - bz**2
  If (scheck<=0) Then
    Write (99, *) 'scheck44: ', scheck
    Stop
  End If
  ga = 1./sqrt(scheck)
  elnc = eln/ga
  pn2 = ((elnc**2+ana**2-ala**2)/(2.*elnc))**2 - ana**2
  If (pn2<=0.) pn2 = 1.E-09
  pn = sqrt(pn2)
  csn = 1. - 2.*ranart(nseed)
  ssn = sqrt(1.-csn**2)
  fain = 2.*3.14*ranart(nseed)
  px = pn*ssn*cos(fain)
  py = pn*ssn*sin(fain)
  pz = pn*csn
  en = sqrt(ana**2+pn2)
  plx = -px
  ply = -py
  plz = -pz
  pbeta = px*bx + py*by + pz*bz
  trans0 = ga*(ga*pbeta/(ga+1.)+en)
  px = bx*trans0 + px
  py = by*trans0 + py
  pz = bz*trans0 + pz
  el = sqrt(ala**2+plx**2+ply**2+plz**2)
  pbeta = plx*bx + ply*by + plz*bz
  trans0 = ga*(ga*pbeta/(ga+1.)+el)
  plx = bx*trans0 + plx
  ply = by*trans0 + ply
  plz = bz*trans0 + plz
  Return
End Subroutine bbkaon


MODULE neo_rk4dbo
  INTERFACE rk4d_bo
     SUBROUTINE rk4d_bo1(x,y,h)
       USE neo_precision
       REAL(dp),               INTENT(inout) ::  x
       REAL(dp),               INTENT(in)    ::  h
       REAL(dp), DIMENSION(:), INTENT(inout) ::  y
     END SUBROUTINE rk4d_bo1
  END INTERFACE
END MODULE neo_rk4dbo


!----------------------------------------------------------------------------- best with 100 columns

function multiFront1()
  use modSparse
  integer::multiFront1
  type(multiFront)::p
  integer::iA(7),jA(7)
  double precision::A(7)
  double precision::rhs(4),x(4)

  multiFront1=0
  call p%init(4,10)
  iA=[1,2,2,3,3,4,4]
  jA=[1,2,1,3,4,4,2]
  A=[1d0,2d0,-1d0,5d0,-4d0,2d0,-1d0]
  rhs=[1d0,2d0,3d0,4d0]
  call p%setCOO(iA,jA,A,7,job=CSR_CLEAN_SORT)
  call p%fact()
  call p%solve(rhs,x)
  if(norm2(x-[1d0,3d0/2d0,14d0/5d0,11d0/4d0])>1d-9)then
    multiFront1=1
  end if

end function


      subroutine rotate(fin,rot,fout,Nw,Nd)
      implicit none
      integer Nw, Nd
      complex*16 fin(Nw,Nd,Nd), fout(Nw,Nd), rot(Nd,Nd)
Cf2py intent(in) fin,rot,Nw,Nd
Cf2py intent(out) fout

      ! local vars
      integer i,j,k
      complex*16 tmp(Nd,Nd)

!$OMP PARALLEL SHARED(fin,rot,fout) PRIVATE(i,j,tmp)
!$OMP DO
      do i=1,Nw
        call mat_transform(fin(i,:,:), rot, tmp, Nd, 1)
        do j=1,Nd
          fout(i,j) = tmp(j,j);
        enddo
      enddo
!$OMP END PARALLEL
      end

      subroutine irotate(fin,rot,fout,Nw,Nd)
      implicit none
      integer Nw, Nd
      complex*16 fin(Nw,Nd), fout(Nw,Nd,Nd), rot(Nd,Nd)
Cf2py intent(in) fin,rot,Nw,Nd
Cf2py intent(out) fout

      ! local vars
      integer i,j,k
      complex*16 tmp(Nd,Nd)

!$OMP PARALLEL SHARED(fin,rot,fout) PRIVATE(i,j,tmp)
!$OMP DO
      do i=1,Nw
        tmp = 0;
        do j=1,Nd
          tmp(j,j) = fin(i,j);
        enddo
        call mat_transform(tmp, rot, fout(i,:,:), Nd, 0)
      enddo
!$OMP END PARALLEL
      end

      subroutine mat_transform(A,B,C,L, direction)
      ! return C = BxAxB^t if direction > 0
      ! return C = B^txAxB if direction = 0
      ! input A a symmetric matrix of size L
      complex*16 A(L,L), B(L,L), C(L,L), tmp(L,L)
      integer L, direction
      character C1, C2
      complex*16 ALPHA,BETA

      ALPHA=1.0; BETA=0.0;

      if (direction > 0) then
          !dsymm to the right: BxA
          C1='N'; C2='N'
          call zgemm(C1,C2,L,L,L,ALPHA,B,L,A,L,BETA,tmp,L)

          !dgemm with B^t: BxAxB^t
          C1='N'; C2='C' ! here is Hermitian conjugate
          call zgemm(C1,C2,L,L,L,ALPHA,tmp,L,B,L,BETA,C,L)
      else
          !dsymm to the left: AxB
          C1='N'; C2='N'
          call zgemm(C1,C2,L,L,L,ALPHA,A,L,B,L,BETA,tmp,L)

          !dgemm with B^t: B^txAxB
          C1='C'; C2='N' ! Hermitian conjugate
          call zgemm(C1,C2,L,L,L,ALPHA,B,L,tmp,L,BETA,C,L)
      endif
      end


          PROGRAM MAIN

          USE OMP_LIB
          IMPLICIT NONE

          INTEGER :: i
          INTEGER, PARAMETER :: num_steps = 100000000
          REAL*8 :: x, pi, sum, step
          REAL*8 :: start_time, run_time

          sum = 0.0

          step = 1.0/num_steps
          start_time = OMP_GET_WTIME()

          DO i = 1, num_steps
             x = (i - 0.5) * step
             sum = sum + 4.0 / (1.0 + x * x)
          ENDDO

          pi = step * sum
          run_time = OMP_GET_WTIME() - start_time

          WRITE(*,100) pi, num_steps,  run_time
100       FORMAT('pi = ', f15.8, ',', i14, ' steps,',f8.3,' secs')

          END PROGRAM MAIN


C*PL*ERROR* Comment line too long
c -----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION DPSLHY1(PRES,Z,TV,XMSG)
      IMPLICIT NONE

c Compute sea level pressure (Pa) via the hypsometric eqn

c NCL: slp = pslhy1 (pres,z,tv)

c input

c pressure on lowest vertical level (Pa)
      DOUBLE PRECISION PRES
c Geopotential hgt of lowest vertical level (m)
      DOUBLE PRECISION Z
c virtual temperature (K)
      DOUBLE PRECISION TV
c missing value
      DOUBLE PRECISION XMSG

c output

c sea level pressure (Pa)
c     real pslhy1

c local

c gravity (m/s2)
      DOUBLE PRECISION G
c gas const dry air (j/{kg-k})
      DOUBLE PRECISION RDAIR
      DATA G/9.80665D0/
      DATA RDAIR/287.04D0/

c pres_msg, zmsg, tvmsg
      IF (PRES.NE.XMSG .AND. Z.NE.XMSG .AND. TV.NE.XMSG) THEN
          DPSLHY1 = PRES*EXP(G*Z/ (RDAIR*TV))
      ELSE
c pres_msg
          DPSLHY1 = XMSG
      END IF

      RETURN
      END
C*PL*ERROR* Comment line too long
c -----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION DPSLHY2(PRES,Z,T,W,XMSG)
      IMPLICIT NONE

c Compute sea level pressure (Pa) via the hypsometric eqn

c NCL: slp = pslhy2 (pres,z,t,w)

c input

c pressure on lowest vertical level (Pa)
      DOUBLE PRECISION PRES
c Geopotential hgt of lowest vertical level (m)
      DOUBLE PRECISION Z
c temperature (K)
      DOUBLE PRECISION T
c mixing ratio (kg/kg) [specific hum couls also be used]
      DOUBLE PRECISION W
c missing value
      DOUBLE PRECISION XMSG

c output

c sea level pressure (Pa)
c     real pslhy2

c local

c virtual temperature (K)
      DOUBLE PRECISION TV
c gravity (m/s2)
      DOUBLE PRECISION G
c gas const dry air (j/{kg-k})
      DOUBLE PRECISION RDAIR
      DATA G/9.80665D0/
      DATA RDAIR/287.04D0/

c pres_msg, zmsg, tvmsg, wmsg
      IF (PRES.NE.XMSG .AND. Z.NE.XMSG .AND. T.NE.XMSG .AND.
     +    W.NE.XMSG) THEN
          TV = T* (1.D0+0.608D0*W)
          DPSLHY2 = PRES*EXP(G*Z/ (RDAIR*TV))
      ELSE
c pres_msg
          DPSLHY2 = XMSG
      END IF

      RETURN
      END
C*PL*ERROR* Comment line too long
c ----------------------------------------------------------------------------
      SUBROUTINE DPSLEC(T,PHIS,PS,PRES,MLON,NLAT,PSL)
      IMPLICIT NONE

c Compute sea level pressure using the ECMWF formulation.
c Uses same routine as CCM Processor's derived field: PSLECMWF

c NCL: slp = pslec (t,phis,ps,pres)
c input

c Number of longitude values
      INTEGER MLON
c Number of latitude values
      INTEGER NLAT

c Temperature of lowest vertical level (K)
      DOUBLE PRECISION T(MLON,NLAT)
c Surface geopotential (m^2/s^2)
      DOUBLE PRECISION PHIS(MLON,NLAT)
c Surface pressure (Pascals)
      DOUBLE PRECISION PS(MLON,NLAT)
c Pressure on lowest vertical level (Pa)
      DOUBLE PRECISION PRES(MLON,NLAT)

c output

c Sea Level Pressure (Pa)
      DOUBLE PRECISION PSL(MLON,NLAT)

c local

c latitude counter
      INTEGER NL

C*PL*ERROR* Comment line too long
c The CCM Processor routine cpslec processes one latitude slice at a time.

      DO NL = 1,NLAT
          CALL DCPSLEC(PRES(1,NL),PHIS(1,NL),PS(1,NL),T(1,NL),MLON,MLON,
     +                 1,PSL(1,NL))
      END DO

      RETURN
      END
C*PL*ERROR* Comment line too long
c ----------------------------------------------------------------------------
      SUBROUTINE DPSLHOR(Z,T,PHIS,PS,PRES,LATS,MLON,NLAT,KLEV,PSL,PSLU,
     +                   ZX,TX,PRESX)
      IMPLICIT NONE

c Compute sea level pressure (Pa)  using the ECMWF formulation and
c     Trenberth's horizontal correction.

c Uses same routine as CCM Processor's derived field: PSLHOR2.

c NCL: slp = pslhor (z,t,phis,ps,pres,lats)

c input

c Number of longitude values
      INTEGER MLON
c Number of latitude values
      INTEGER NLAT
c Number of vertical levels
      INTEGER KLEV

c Geopotential Height Units: meters
      DOUBLE PRECISION Z(MLON,NLAT,KLEV)
c Temperature (K)
      DOUBLE PRECISION T(MLON,NLAT,KLEV)
c Surface geopotential (m^2/s^2)
      DOUBLE PRECISION PHIS(MLON,NLAT)
c Surface pressure (Pa)
      DOUBLE PRECISION PS(MLON,NLAT)
c Pressure (Pa)
      DOUBLE PRECISION PRES(MLON,NLAT,KLEV)
c Latitudes (degrees)
      DOUBLE PRECISION LATS(NLAT)

c output

c Sea Level Pressure (Pa)
      DOUBLE PRECISION PSL(MLON,NLAT)

c local (arrays auto allocation)

c loop counters
      INTEGER ML,NL,KL
c psl from PSLEC, uncorrected
      DOUBLE PRECISION PSLU(MLON,NLAT)
c temp
      DOUBLE PRECISION ZX(MLON,KLEV)
c temp
      DOUBLE PRECISION TX(MLON,KLEV)
c temp
      DOUBLE PRECISION PRESX(MLON,KLEV)

C*PL*ERROR* Comment line too long
c The CCM Processor routine cpslec processes one latitude slice at a time.

      KL = 1
      DO NL = 1,NLAT
          CALL DCPSLEC(PRES(1,NL,KL),PHIS(1,NL),PS(1,NL),T(1,NL,KL),
     +                 MLON,MLON,1,PSLU(1,NL))
      END DO

c Do the horizontal correction
C*PL*ERROR* Comment line too long
c The CCM Processor routine cpslhor2 processes one latitude slice at a time
c   and expects data from top to bottom.

      DO NL = 1,NLAT

          DO KL = 1,KLEV
              DO ML = 1,MLON
c must be in reverse order
                  ZX(ML,KL) = Z(ML,NL,KLEV+1-KL)
c must be in reverse order
                  TX(ML,KL) = T(ML,NL,KLEV+1-KL)
c must be in reverse order
                  PRESX(ML,KL) = PRES(ML,NL,KLEV+1-KL)
              END DO
          END DO

          CALL DCPSLHOR2(PRESX,ZX,PHIS(1,NL),PSLU(1,NL),PS(1,NL),TX,
     +                   MLON,MLON,KLEV,LATS(NL),PSL(1,NL))
      END DO

      RETURN
      END
C*PL*ERROR* Comment line too long
c ----------------------------------------------------------------------------
      SUBROUTINE DCPSLEC(PRES,PHIS,PS,T,IDIM,IMAX,KMAX,PSL)
      DOUBLE PRECISION RD
      DOUBLE PRECISION G
      DOUBLE PRECISION XLAPSE
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION TSTAR
      DOUBLE PRECISION T0
      DOUBLE PRECISION ALPH
      DOUBLE PRECISION BETA
c
c       File:   /crestone/u0/ccmproc2/src/src/cpslec.F  (2312 bytes)
c       Date:   Wed Dec  1 16:07:19 1993
c       Author: Lawrence Buja <ccmproc2@sunny>
c
c       From:   inderf
c       Calls:  ** none **
c       Blocks: ** none **
c
c-----------------------------------------------------------------------
c
c       CCM2 hybrid coord version using ECMWF formulation
c       Purpose:   Compute sea level pressure for a latitude line
c       Algorithm: See section 3.1.b in NCAR NT-396 "Vertical
c                  Interpolation and Truncation of Model-Coordinate Data
c
c-----------------------------Arguments---------------------------------
c
c Input
c Atmospheric pressure (pascals)
      DOUBLE PRECISION PRES(IDIM,KMAX)
c Surface geopotential (m**2/sec**2)
      DOUBLE PRECISION PHIS(IDIM)
c Surface pressure (pascals)
      DOUBLE PRECISION PS(IDIM)
c Vertical slice of temperature (top to bot)
      DOUBLE PRECISION T(IDIM,KMAX)
c First dimension of phis, ps, and t
      INTEGER IDIM
c Number of longitude points to compute
      INTEGER IMAX
c Number of levels in t (2nd dimension)
      INTEGER KMAX
c
c Output
c
c Sea level pressures (pascals)
      DOUBLE PRECISION PSL(IDIM)
c
c-----------------------------Parameters--------------------------------
c
      PARAMETER (RD=287.04D0,G=9.80616D0,XLAPSE=6.5D-3)
      PARAMETER (ALPHA=RD*XLAPSE/G)
c
c-----------------------------------------------------------------------
c
      DO I = 1,IMAX
         IF (ABS(PHIS(I)/G) .LT. 1.D-4) THEN
            PSL(I) = PS(I)
         ELSE
c pg 7 eq 5
            TSTAR = T(I,KMAX)* (1.D0+ALPHA* (PS(I)/PRES(I,KMAX)-1.D0))

c pg 8 eq 13
            T0 = TSTAR + XLAPSE*PHIS(I)/G

c pg 8 eq 14.1
            IF (TSTAR.LE.290.5D0 .AND. T0.GT.290.5D0) THEN
               ALPH = RD/PHIS(I)* (290.5D0-TSTAR)
c pg 8 eq 14.2
            ELSE IF (TSTAR.GT.290.5D0 .AND. T0.GT.290.5D0) THEN
               ALPH = 0.D0
               TSTAR = 0.5D0* (290.5D0+TSTAR)
            ELSE
               ALPH = ALPHA
            END IF
            IF (TSTAR.LT.255.D0) THEN
c pg 8 eq 14.3
               TSTAR = 0.5D0* (255.D0+TSTAR)
            END IF
            BETA = PHIS(I)/ (RD*TSTAR)
            PSL(I) = PS(I)*EXP(BETA* (1.D0-ALPH*BETA/2.D0+
     +           ((ALPH*BETA)**2)/3.D0))
         END IF
      END DO
      RETURN
      END
C*PL*ERROR* Comment line too long
c ----------------------------------------------------------------------------
      SUBROUTINE DCPSLHOR2(PRES,Z,PHIS,PSL,PS,T,IDIM,IMAX,KMAX,DLAT,
     +                     PSLHOR)
      DOUBLE PRECISION RD
      DOUBLE PRECISION G
      DOUBLE PRECISION XLAPSE
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION ZMIN
      DOUBLE PRECISION ZMID
      DOUBLE PRECISION ZA
      DOUBLE PRECISION ZF
      DOUBLE PRECISION PA
      DOUBLE PRECISION PF
      DOUBLE PRECISION DPA
      DOUBLE PRECISION DPF
      DOUBLE PRECISION FACTOR
c
c       File:   /crestone/u0/ccmproc2/src/src/cpslhor.F  (12843 bytes)
c       Date:   Wed Dec  8 13:42:48 1993
c       Author: Lawrence Buja <ccmproc2@sunny>
c
c       From:   inderf
c       Calls:  ** none **
c       Blocks: ** none **
c
c-----------------------------------------------------------------------
c
c       PSL via Trenberth's horizontal formulation
c       Purpose:   Compute sea level pressure for a latitude line
c       Algorithm:
c
c Designation:  --Low Area----|-------High Area------|---Low Area--
c                               ___________________
c                              /
c                             /_ _ _ _ _ _ _ _ _ _ _
c                            /      2000 meters
c                           /
c Surface:      ------------                           ------------
c Gridpoints:        X     X     X     X     X     X     X     X
c Counters:          A     B     C     D     E     F     G     H
c
c-----------------------------Arguments---------------------------------
c
c Input
c Atmospheric pressure (pascals)
      DOUBLE PRECISION PRES(IDIM,KMAX)
c Geopotential of hybrid levels (m**2/sec**2)
      DOUBLE PRECISION Z(IDIM,KMAX)
c Surface geopotential (m**2/sec**2)
      DOUBLE PRECISION PHIS(IDIM)
c Sea level pressures (pascals)
      DOUBLE PRECISION PSL(IDIM)
c Surface pressure (pascals)
      DOUBLE PRECISION PS(IDIM)
c Vertical slice of temperature (top to bot)
      DOUBLE PRECISION T(IDIM,KMAX)
c First dimension of phis, ps, and t
      INTEGER IDIM
c Number of longitude points to compute
      INTEGER IMAX
c Number of levels in t (2nd dimension)
      INTEGER KMAX
c Current latitude (-90. <= dlat <= +90.00)
      DOUBLE PRECISION DLAT
c
c Output
c
c PSL with Horiz correction (pascals)
      DOUBLE PRECISION PSLHOR(IDIM)
c
c-----------------------------Parameters--------------------------------
c
      PARAMETER (RD=287.04D0,G=9.80616D0,XLAPSE=6.5D-3)
      PARAMETER (ALPHA=RD*XLAPSE/G)
c
c--------------------------Local variables------------------------------
c
c Surrounding end points (2 on each bdry)
      INTEGER IENDPTS(10,2)
c if region lon1 thru lon2 is > 2000meters

c  1st dim: Assume there are multiple high

c           areas on 1 latitude line.

c  2nd dim: (N,1)= 1st  lon of high area N

c           (N,2)= Last lon of high area N

c Counter for first dimension of iendpts.
      INTEGER NEND
c .True. = looking for high area
      LOGICAL LSTART
c .False.= looking for low area

c
c-----------------------------------------------------------------------
c
c Min height of a "high" area.
      ZMIN = 2000.D0
c Max height to use PSL data for interpolation
      ZMID = 1250.D0
      NEND = 0
      LSTART = .true.
      LASTINDEX = 0
      DO I = 1,IMAX
c This a high area and
c Latitude is .gt. -60.00
          IF (PHIS(I)/G.GT.ZMIN .AND. DLAT.GT.-60.00D0) THEN
c Is this 1st long of high area?
              IF (LSTART) THEN
c > 2 points away from last area
                  IF (I-LASTINDEX.GT.3) THEN
c Increment counter.
                      NEND = NEND + 1
c Set beginning point index (i1)
                      IENDPTS(NEND,1) = I
c In High area, search for low area
                      LSTART = .false.
c < 2 points from last high area.
                  ELSE
c  merge last area into this area
                      LSTART = .false.
                  END IF
              END IF
c This is a low area
          ELSE
c PSL is not modified.
              PSLHOR(I) = PSL(I)
c 1st long of low area
              IF (.NOT.LSTART) THEN
c In low area, search for high area
                  LSTART = .true.
c Set end point index (i2)
                  IENDPTS(NEND,2) = I - 1
                  LASTINDX = I - 1
              END IF
          END IF
      END DO

      DO N = 1,NEND
c Beginning index of high area
          I1 = IENDPTS(N,1)
c Last index of high area
          I2 = IENDPTS(N,2)
          DO WHILE (PHIS(I1)/G.GT.ZMID)
              I1 = I1 - 1
          END DO
          DO WHILE (PHIS(I2)/G.GT.ZMID)
              I2 = I2 + 1
          END DO
          I1 = I1 + 1
          I2 = I2 - 1
c loop over longitude from C to F
          DO I = I1,I2
c Z Foes from 1=top to kmax=bottom
              DO LEV = 1,KMAX
                  IF (Z(I1-1,LEV).GT.PHIS(I)/G) LEVA = LEV
                  IF (Z(I2+1,LEV).GT.PHIS(I)/G) LEVF = LEV
              END DO
c
c  zA is hgt of PHIS(i1) at point i1 minus 2.
c
              ZA = (PHIS(I)/G-Z(I1-1,LEVA+1))/
     +             (Z(I1-1,LEVA)-Z(I1-1,LEVA+1))
              ZF = (PHIS(I)/G-Z(I2+1,LEVF+1))/
     +             (Z(I2+1,LEVF)-Z(I2+1,LEVF+1))
c
c PA is Pressure at the 2000 meter level at point i1 minus 2
c        (pres goes from 1=top down to kmax=bottom)
c
              PA = EXP(LOG(PRES(I1-1,LEVA+1))-
     +             LOG(PRES(I1-1,LEVA+1)/PRES(I1-1,LEVA))*ZA)
              PF = EXP(LOG(PRES(I2+1,LEVF+1))-
     +             LOG(PRES(I2+1,LEVF+1)/PRES(I2+1,LEVF))*ZF)

              DPA = PSL(I1-1) - PA
              DPF = PSL(I2+1) - PF
              FACTOR = DBLE(I-I1)/DBLE(I2-I1)
              PSLHOR(I) = PS(I) + (FACTOR*DPF+ (1-FACTOR)*DPA)
          END DO
      END DO

      RETURN
      END

C======================================================================

      SUBROUTINE DCPSLHOR(PRES,Z,PHIS,PSL,PS,T,IDIM,IMAX,KMAX,DLAT,
     +                    PSLHOR)
      DOUBLE PRECISION RD
      DOUBLE PRECISION G
      DOUBLE PRECISION XLAPSE
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION ZMIN
      DOUBLE PRECISION ZA
      DOUBLE PRECISION ZB
      DOUBLE PRECISION ZG
      DOUBLE PRECISION ZH
      DOUBLE PRECISION PA
      DOUBLE PRECISION PB
      DOUBLE PRECISION PG
      DOUBLE PRECISION PH
      DOUBLE PRECISION DPA
      DOUBLE PRECISION DPB
      DOUBLE PRECISION DPG
      DOUBLE PRECISION DPH
      DOUBLE PRECISION DPAB
      DOUBLE PRECISION DPGH
      DOUBLE PRECISION FACTOR
c
c       File:   /crestone/u0/ccmproc2/src/src/cpslhor.F  (6747 bytes)
c       Date:   Tue Dec  7 13:52:48 1993
c       Author: Lawrence Buja <ccmproc2@sunny>
c
c       From:   inderf
c       Calls:  ** none **
c       Blocks: ** none **
c
c-----------------------------------------------------------------------
c
c       PSL via Trenberth's horizontal formulation
c       Purpose:   Compute sea level pressure for a latitude line
c       Algorithm:
c
c Designation:  --Low Area----|-------High Area------|---Low Area--
c                               ___________________
c                              /
c                             /_ _ _ _ _ _ _ _ _ _ _
c                            /      2000 meters
c                           /
c Surface:      ------------                           ------------
c Gridpoints:        X     X     X     X     X     X     X     X
c Counters:          A     B     C     D     E     F     G     H
c
c-----------------------------Arguments---------------------------------
c
c Input
c Atmospheric pressure (pascals)
      DOUBLE PRECISION PRES(IDIM,KMAX)
c Geopotential of hybrid levels (m**2/sec**2)
      DOUBLE PRECISION Z(IDIM,KMAX)
c Surface geopotential (m**2/sec**2)
      DOUBLE PRECISION PHIS(IDIM)
c Sea level pressures (pascals)
      DOUBLE PRECISION PSL(IDIM)
c Surface pressure (pascals)
      DOUBLE PRECISION PS(IDIM)
c Vertical slice of temperature (top to bot)
      DOUBLE PRECISION T(IDIM,KMAX)
c First dimension of phis, ps, and t
      INTEGER IDIM
c Number of longitude points to compute
      INTEGER IMAX
c Number of levels in t (2nd dimension)
      INTEGER KMAX
c Current latitude (-90. <= dlat <= +90.00)
      DOUBLE PRECISION DLAT
c
c Output
c
c PSL with Horiz correction (pascals)
      DOUBLE PRECISION PSLHOR(IDIM)
c
c-----------------------------Parameters--------------------------------
c
      PARAMETER (RD=287.04D0,G=9.80616D0,XLAPSE=6.5D-3)
      PARAMETER (ALPHA=RD*XLAPSE/G)
c
c--------------------------Local variables------------------------------
c
c Surrounding end points (2 on each bdry)
      INTEGER IENDPTS(10,2)
c if region lon1 thru lon2 is > 2000meters

c  1st dim: Assume there are multiple high

c           areas on 1 latitude line.

c  2nd dim: (N,1)= 1st  lon of high area N

c           (N,2)= Last lon of high area N

c Counter for first dimension of iendpts.
      INTEGER NEND
c .True. = looking for high area
      LOGICAL LSTART
c .False.= looking for low area

c
c-----------------------------------------------------------------------
c
      ZMIN = 2000.D0
      NEND = 0
      LSTART = .true.
      LASTINDEX = 0
      DO I = 1,IMAX
c This a high area and
c Latitude is .gt. -60.00
          IF (PHIS(I)/G.GT.ZMIN .AND. DLAT.GT.-60.00D0) THEN
c Is this 1st long of high area?
              IF (LSTART) THEN
c > 2 points away from last area
                  IF (I-LASTINDEX.GT.3) THEN
c Increment counter.
                      NEND = NEND + 1
c Set beginning point index (i1)
                      IENDPTS(NEND,1) = I
c In High area, search for low area
                      LSTART = .false.
c < 2 points from last high area.
                  ELSE
c  merge last area into this area
                      LSTART = .false.
                  END IF
              END IF
c This is a low area
          ELSE
c PSL is not modified.
              PSLHOR(I) = PSL(I)
c 1st long of low area
              IF (.NOT.LSTART) THEN
c In low area, search for high area
                  LSTART = .true.
c Set end point index (i2)
                  IENDPTS(NEND,2) = I - 1
                  LASTINDX = I - 1
              END IF
          END IF
      END DO

      DO N = 1,NEND
c Beginning index of high area
          I1 = IENDPTS(N,1)
c Last index of high area
          I2 = IENDPTS(N,2)
c loop over longitude from C to F
          DO I = I1,I2
c Z goes from 1=top to kmax=bottom
              DO LEV = 1,KMAX
                  IF (Z(I1-2,LEV).GT.PHIS(I)/G) LEVA = LEV
                  IF (Z(I1-1,LEV).GT.PHIS(I)/G) LEVB = LEV
                  IF (Z(I2+1,LEV).GT.PHIS(I)/G) LEVG = LEV
                  IF (Z(I2+2,LEV).GT.PHIS(I)/G) LEVH = LEV
              END DO
c
c  zA is hgt of PHIS(i1) at point i1 minus 2.
c
              ZA = (PHIS(I)/G-Z(I1-2,LEVA+1))/
     +             (Z(I1-2,LEVA)-Z(I1-2,LEVA+1))
              ZB = (PHIS(I)/G-Z(I1-1,LEVB+1))/
     +             (Z(I1-1,LEVB)-Z(I1-1,LEVB+1))
              ZG = (PHIS(I)/G-Z(I2+1,LEVG+1))/
     +             (Z(I2+1,LEVG)-Z(I2+1,LEVG+1))
              ZH = (PHIS(I)/G-Z(I2+2,LEVH+1))/
     +             (Z(I2+2,LEVH)-Z(I2+2,LEVH+1))
c
c PA is Pressure at the 2000 meter level at point i1 minus 2
c        (pres goes from 1=top down to kmax=bottom)
c
              PA = EXP(LOG(PRES(I1-2,LEVA+1))-
     +             LOG(PRES(I1-2,LEVA+1)/PRES(I1-2,LEVA))*ZA)
              PB = EXP(LOG(PRES(I1-1,LEVB+1))-
     +             LOG(PRES(I1-1,LEVB+1)/PRES(I1-1,LEVB))*ZB)
              PG = EXP(LOG(PRES(I2+1,LEVG+1))-
     +             LOG(PRES(I2+1,LEVG+1)/PRES(I2+1,LEVG))*ZG)
              PH = EXP(LOG(PRES(I2+2,LEVH+1))-
     +             LOG(PRES(I2+2,LEVH+1)/PRES(I2+2,LEVH))*ZH)
              DPA = PSL(I1-2) - PA
              DPB = PSL(I1-1) - PB
              DPG = PSL(I2+1) - PG
              DPH = PSL(I2+2) - PH
              DPAB = (DPA+DPB)*0.5D0
              DPGH = (DPG+DPH)*0.5D0
c          if (Lprint) then
c             print *,' cpslhor.100: Levs= ',levA,levB,levG,levH
c             print *,' cpslhor.101: Zs=   ',zA,zB,zG,zH
c             print *,' cpslhor.102: Ps=   ',pA,pB,pG,pH
c             print *,' cpslhor.103: dps=  ',dpA,dpB,dpG,dpH,dpAB,dpGH
c           endif
              FACTOR = (I-I1+1.5D0)/ (I2-I1+3)
              PSLHOR(I) = PS(I) + (FACTOR*DPGH+ (1-FACTOR)*DPAB)
          END DO
      END DO
      RETURN
      END


C WIDENT.F - Gateway function for computation of a discrete-time
C            model of a Wiener system using SLICOT routine IB03BD.
C
C RELEASE 2.0 of SLICOT System Identification Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab calls:
C   [xopt(,perf,nf,rcnd)] = wident(job,u,y,nn(,s,n,x,iter,nprint,tol,
C                                  seed,printw,ldwork))
C
C   [xopt(,perf,nf,rcnd)] = wident(1,u,y,nn,s,n,x(,iter,nprint,tol,
C                                  printw,ldwork))
C   [xopt(,perf,nf)]      = wident(2,u,y,nn,n,x(,iter,nprint,tol,
C                                  seed,printw,ldwork))
C   [xopt(,perf,nf,rcnd)] = wident(3,u,y,nn,s(,n,[],iter,nprint,tol,
C                                  seed,printw,ldwork))
C   [xopt(,perf,nf)]      = wident(4,u,y,nn,n,x(,iter,nprint,tol,
C                                  printw,ldwork))
C
C Purpose:
C   To compute a set of parameters for approximating a Wiener system
C   in a least-squares sense, using a neural network approach and a
C   MINPACK-like Levenberg-Marquardt algorithm.
C
C Input parameters:
C   job    - integer specifying which parameters must be initialized:
C            = 1 : initialize the linear part only;
C            = 2 : initialize the static nonlinearity only;
C            = 3 : initialize both linear and nonlinear parts;
C            = 4 : do not initialize anything, x already contains
C                  an initial approximation.
C   u      - the t-by-m input trajectory, where t is the number of
C            samples.
C   y      - the t-by-l output trajectory.
C   nn     - the number of neurons used to approximate the nonlinear
C            part.
C   s      - if job = 1 or 3, the number of block rows in the input and
C            output block Hankel matrices to be processed.  s > 0.
C            The argument s must not be specified if job = 2 or 4.
C   n      - (optional) the order of the linear part of the system or
C            an option for how to compute it.
C            If job = 1 or 3, and n < 0, the order will be found by the
C            program. Otherwise, n should be non-negative (or positive,
C            but less than s, if job = 1 or 3).
C            The value of n should be given if job = 2 or 4.
C            Default for job = 1 or 3: the order found automatically.
C   x      - the lx0 vector of initial parameters, where
C            lx0 = l1,  if job = 1,
C            lx0 = l2,  if job = 2,
C            lx0 = lx,  if job = 4,
C            with l1 = (nn*(l+2)+1)*l, l2 = n*(l+m+1)+l*m, lx = l2+l1.
C            Here, l1 is the number of parameters for the nonlinear part
C            and l2 is the number of parameters for the linear part.
C            If n < 0 on entry, then s-1 is used instead of n for
C            setting l2 and lx, and for allocating the workspace.
C            If job = 3, the vector x is not needed.
C   iter   - (optional) vector of length 2 containing the maximal
C            numbers of iterations for the Levenberg-Marquardt algorithm
C            for the initialization of the static nonlinearity (ignored
C            if job = 1 or 4), and for the optimization process; these
C            numbers are stored in iter(1) and iter(2), respectively.
C            Default: iter = [10*lx 10*lx].
C   nprint - (optional) integer specifying the frequency of printing
C            details of the optimization process. If nprint > 0, the
C            intermediate results are printed in the file IB03BD.prn,
C            which is overwritten at each execution of this mexfile.
C            Default: nprint = 0 (no printing).
C   tol    - (optional) vector of length 2 containing the absolute
C            tolerances for the initialization of the static
C            nonlinearity (ignored if job = 1 or 4), and for the
C            optimization process, respectively.
C            Default: tol = [sqrt(eps) sqrt(eps)], with
C            eps = epsilon_machine.
C   seed   - (optional) if job = 2 or 3, vector of length 4 containing
C            the random number generator seed used to initialize the
C            parameters of the static nonlinearity.
C   printw - (optional) switch for printing the warning messages.
C            = 1:  print warning messages;
C            = 0:  do not print warning messages.
C            Default:    printw = 0.
C   ldwork - (optional) the length of working array.
C            Default: the minimum workspace needed, computed by the
C                     program based on the specified input arguments.
C            Larger values could increase the efficiency.
C
C Output parameters:
C   xopt   - the lx vector of optimal parameters.
C            The corresponding linear system and its initial state can
C            be found as follows:
C            m = size(u,2);  l = size(y,2);  l1 = (nn*(l+2)+1)*l;
C            n = ( length(xopt) - l1 - l*m ) / ( l+m+1 );
C            [A,B,C,D,x0] = onf2ss(n,m,l,xopt(l1+1:end),1);
C   perf   - (optional) vector of length 4 or 8 containing performance
C            results:
C            perf(1) contains the optimal value of the workspace length;
C            perf(2) contains the maximum residual error norm;
C            perf(3) contains the total number of iterations performed;
C            perf(4) contains the final Levenberg factor.
C            If job = 2 or 3, then similar results for the nonlinear
C            part initialization step are returned:
C            perf(5) contains the optimal value of the workspace length;
C            perf(6) contains the maximum residual error norm;
C            perf(7) contains the total number of iterations performed;
C            perf(8) contains the final Levenberg factor (maximum over
C                    all outputs).
C   nf     - (optional) 2-vector containing additional performance
C            results:
C            nf(1) contains the (total) number of function evaluations;
C            nf(2) contains the (total) number of Jacobian evaluations.
C   rcnd   - (optional) if job = 1 or 3, vector of suitable length
C            containing the reciprocal condition number estimates for
C            determining the linear part by susbspace techniques.
C
C Contributor:
C   V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001.
C
C Revisions:
C   V. Sima, Katholieke University Leuven, Belgium, Feb. 2002,
C   Apr. 2009, Dec. 2012.
C
C **********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
C     .. NOUT is the unit number for printing intermediate results ..
C     .. if NPRINT is positive ..
      INTEGER           NOUT
      PARAMETER         ( NOUT = 6 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         INIT
      INTEGER           INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK,
     $                  LDY, LX, M, N, NN, NOBR, NPRINT, NSMP
      DOUBLE PRECISION  TOL1, TOL2
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE :: DWORK(:), U(:,:), X(:), Y(:,:)
      INTEGER,          ALLOCATABLE :: IWORK(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      LOGICAL           INIT1, INIT2, PRINTW
      INTEGER           BSN, INI, IP, ISAD, ISIZE, ITMP, IW1, IW2, IW3,
     $                  IX, JWORK, L1, L2, LDAC, LDWMIN, LIWORK, LNOL,
     $                  LPAR, LPAR0, M1, M2, ML, MNO, N2, NS, NSML, NX,
     $                  TASK
      DOUBLE PRECISION  RSEED(4), TEMP, TMP(4)
C
C .. External functions ..
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C
C .. External subroutines ..
      EXTERNAL          DCOPY, IB03BD
C
C .. Intrinsic functions ..
      INTRINSIC         INT, MAX, MIN, SQRT
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'WIDENT requires at least 4 input arguments' )
      ELSE IF ( NLHS.LT.1 ) THEN
         CALL mexErrMsgTxt
     $        ( 'WIDENT requires at least 1 output arguments' )
      END IF
C
C   job, u(t*m), y(t*l), nn, s, n, x(lx0), iter(2), nprint, tol(2),
C   seed, printw, ldwork
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR.
     $     mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'JOB must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      TASK = TEMP
      IF ( TASK.LT.0 .OR. TASK.GT.4 ) THEN
         CALL mexErrMsgTxt( 'JOB has 1 : 4 the only admissible values' )
      END IF
C
      IF ( TASK.EQ.1 ) THEN
         INIT = 'L'
      ELSE IF ( TASK.EQ.2 ) THEN
         INIT = 'S'
      ELSE IF ( TASK.EQ.3 ) THEN
         INIT = 'B'
      ELSE
         INIT = 'N'
      END IF
      INIT1 = MOD( TASK, 2 ).EQ.1
      INIT2 = TASK.EQ.2 .OR. TASK.EQ.3
C
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'U must be a real matrix' )
      END IF
      NSMP = mxGetM( PRHS(2) )
      M    = mxGetN( PRHS(2) )
      IF ( NSMP.LT.0 .OR. M.LT.0 ) THEN
         CALL mexErrMsgTxt( 'U must be a real matrix' )
      END IF
C
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'Y must be a real matrix' )
      END IF
      ITMP = mxGetM( PRHS(3) )
      L    = mxGetN( PRHS(3) )
      IF ( ITMP.LT.0 .OR. L.LT.0 ) THEN
         CALL mexErrMsgTxt( 'Y must be a real matrix' )
      END IF
      IF ( ITMP.NE.NSMP ) THEN
         CALL mexErrMsgTxt
     $       ( 'Y must have the same row dimension as U' )
      END IF
C
      IF ( mxGetM( PRHS(4) ).NE.1 .OR.
     $     mxGetN( PRHS(4) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'NN must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'NN must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), TEMP, 1 )
      NN = TEMP
      IF ( NN.LT.0 ) THEN
         CALL mexErrMsgTxt( 'NN must be a non-negative integer' )
      END IF
C
      IP = 5
      IF ( NRHS.GE.IP .AND. INIT1 ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'NOBR (s) must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'NOBR must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         NOBR = TEMP
         IF ( NOBR.LE.0 ) THEN
            CALL mexErrMsgTxt( 'NOBR must be a positive integer' )
         END IF
         IP = IP + 1
      END IF
C
      IF ( NRHS.GE.IP ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'N must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'N must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         N = TEMP
         IF ( N.LT.0 .AND. .NOT.INIT1 ) THEN
            CALL mexErrMsgTxt( 'N must be a non-negative integer' )
         END IF
         IP = IP + 1
      ELSE IF ( .NOT. INIT1 ) THEN
         WRITE( TEXT, '('' WIDENT requires at least '',I4,
     $                  '' input arguments'')' ) IP
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      NS = N
      IF ( NS.LT.0 )
     $   N  = NOBR - 1
      ML    = M + L
      BSN   = NN*( L + 2 ) + 1
      L1    = BSN*L
      L2    = N*( ML + 1 ) + L*M
      LPAR0 = 0
      LX    = L1 + L2
      INI   = 1
      IF ( TASK.EQ.1 ) THEN
         LPAR = L1
      ELSE IF ( TASK.EQ.2 ) THEN
         INI  = L1 + 1
         LPAR = L2
      ELSE IF ( TASK.EQ.4 ) THEN
         LPAR = LX
      END IF
C
      IX = IP
      IF ( NRHS.GE.IP ) THEN
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'X must be a real vector' )
         END IF
         M1 = mxGetM( PRHS(IP) )
         M2 = mxGetN( PRHS(IP) )
         IP = IP + 1
         LPAR0 = M1*M2
      END IF
C
      ITMAX1 = 10*LX
      ITMAX2 = 10*LX
      IF ( NRHS.GE.IP ) THEN
C
C   iter
C
         ISIZE = mxGetM( PRHS(IP) )*mxGetN( PRHS(IP) )
         IF ( ISIZE.NE.0 .AND. ISIZE.NE.2 ) THEN
            WRITE( TEXT, '('' ITER must have either 0 or 2 elements'')')
            CALL mexErrMsgTxt( TEXT )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'ITER must be an integer vector' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TMP, ISIZE )
         IF ( ISIZE.GT.0 ) ITMAX1 = INT( TMP(1) )
         IF ( ISIZE.GT.1 ) ITMAX2 = INT( TMP(2) )
         IP = IP + 1
      END IF
C
      NPRINT = 0
      IF ( NRHS.GE.IP ) THEN
C
C   nprint
C
         ISIZE = mxGetM( PRHS(IP) )*mxGetN( PRHS(IP) )
         IF ( ISIZE.NE.0 .AND. ISIZE.NE.1 ) THEN
            WRITE( TEXT,
     $         '('' NPRINT must be either void or with 1 element'')')
            CALL mexErrMsgTxt( TEXT )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'NPRINT must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, ISIZE )
         IF ( ISIZE.GT.0 ) NPRINT = INT( TEMP )
         IF ( NPRINT.GT.0 )
     $      OPEN( NOUT, file = 'IB03BD.prn', status = 'replace' )
         IP = IP + 1
      END IF
C
      TOL1 = SQRT( DLAMCH( 'Epsilon' ) )
      TOL2 = TOL1
      IF ( NRHS.GE.IP ) THEN
C
C   tol
C
         ISIZE = mxGetM( PRHS(IP) )*mxGetN( PRHS(IP) )
         IF ( ISIZE.NE.0 .AND. ISIZE.NE.2 ) THEN
            WRITE( TEXT, '('' TOL must have either 0 or 2 elements'')')
            CALL mexErrMsgTxt( TEXT )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'TOL must be a real vector' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TMP, ISIZE )
         IF ( ISIZE.GT.0 ) TOL1 = TMP(1)
         IF ( ISIZE.GT.1 ) TOL2 = TMP(2)
         IP = IP + 1
      END IF
C
      RSEED(1) = 1998
      RSEED(2) = 1999
      RSEED(3) = 2000
      RSEED(4) = 2001
      IF ( NRHS.GE.IP .AND. INIT2 ) THEN
C
C   seed
C
         ISIZE = mxGetM( PRHS(IP) )*mxGetN( PRHS(IP) )
         IF ( ISIZE.NE.0 .AND. ISIZE.LT.4 ) THEN
            WRITE( TEXT, '('' SEED must have either 0 or 4 elements'')')
            CALL mexErrMsgTxt( TEXT )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'SEED must be an integer or real vector')
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TMP, ISIZE )
         IF ( ISIZE.GT.0 )
     $      CALL DCOPY( ISIZE, TMP, 1, RSEED, 1 )
         IP = IP + 1
      END IF
C
C   printw
C
      PRINTW = .FALSE.
      IF ( NRHS.GE.IP ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'PRINTW must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'PRINTW must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         ITMP = TEMP
         IF ( ITMP.LT.0 .OR. ITMP.GT.1 ) THEN
            CALL mexErrMsgTxt
     $           ( 'PRINTW has 0 or 1 the only admissible values' )
         END IF
         PRINTW = ITMP.EQ.1
         IP = IP + 1
      END IF
C
      LDAC = N + L
      LNOL = L*NOBR - L
      MNO  = M*NOBR
      NSML = NSMP*L
      ISAD = LDAC*( N + M )
      N2   = N*N
C
      JWORK = 0
      IF ( INIT1 ) THEN
C        Workspace for IB01AD.
         JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR
C        Workspace for IB01BD.
         IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N +
     $              MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L,
     $                   2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ),
     $                   MNO + 3*N + L ) )
         IF ( M.GT.0 ) THEN
            IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) +
     $            MAX( LDAC**2, 4*M*LDAC + 1 )
         ELSE
            IW2 = 0
         END IF
         JWORK = MAX( JWORK,
     $                ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) )
C        Workspace for IB01CD.
         IW1   = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N )
         IW2   = N*( N + 1 ) + 2*N +
     $           MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N )
         JWORK = MAX( JWORK, ISAD + N*( N + 1 ) + 2 +
     $                N*( LDAC + M ) +
     $                MAX( 5*N, 2, MIN( IW1, IW2 ) ) )
C        Workspace for TF01MX.
         JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M )
C        Workspace for TB01VD.
         JWORK = MAX( JWORK, NSML + ISAD + N +
     $                MAX( 1, N2*L + N*L + N,
     $                     N2 + MAX( N2 + N*MAX( N, L ) +
     $                               6*N + MIN( N, L ), N*M ) ) )
      END IF
C
      IF ( INIT2 ) THEN
C        Workspace for MD03BD (initialization of the nonlinear part).
         JWORK = MAX( JWORK, NSML + BSN +
     $                MAX( 4, NSMP +
     $                     MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ),
     $                          BSN**2 + BSN +
     $                          MAX( NSMP + 2*NN, 5*BSN ) ) ) )
         IF ( .NOT.INIT1 ) THEN
C           Workspace for TB01VY.
            JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N )
C           Workspace for TF01MX.
            IF ( M.GT.0 ) THEN
               IW1 = N + M
            ELSE
               IW1 = 0
            END IF
            JWORK = MAX( JWORK, NSML + ISAD + IW1 + 2*N + L )
         END IF
      END IF
C     Workspace for MD03BD (whole optimization).
      IF ( M.GT.0 ) THEN
         IW1 = LDAC + M
      ELSE
         IW1 = L
      END IF
      JWORK = MAX( N*LDAC, IW1, JWORK )
      IW1   = NSML + MAX( 2*NN, ISAD + 2*N + JWORK )
      IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN
         IW3 = 4*LX
         IW2 = IW3 + 1
      ELSE
         IW2 = BSN + MAX( 3*BSN + 1, L2 )
         IF ( NSMP.GT.BSN ) THEN
            IW2 = MAX( IW2, 4*L2 + 1 )
            IF ( NSMP.LT.2*BSN )
     $         IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) )
         END IF
         IW3 = L2*BSN + 2*LX + 2*MAX( BSN, L2 )
      END IF
      JWORK = NSML + LX +
     $        MAX( 4, NSML +
     $                MAX( NSML*( BSN + L2 ) +
     $                     MAX( NSML + IW1, IW2 + LX ),
     $                          LX*( BSN + L2 ) + LX +
     $                          MAX( NSML + IW1, LX + IW3 ) ) )
      LDWMIN = JWORK
C
      IF ( NRHS.GE.IP ) THEN
C
C     ldwork
C
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'LDWORK must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
              CALL mexErrMsgTxt( 'LDWORK must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         ITMP = INT( TEMP )
         IF ( ITMP.LT.LDWMIN ) THEN
            LDWORK = LDWMIN
         ELSE
            LDWORK = ITMP
         END IF
      END IF
C
C Determine the lenghts of working arrays.
C
      LDU = MAX( 1, NSMP )
      LDY = LDU
      IF ( NRHS.LT.IP )
     $   LDWORK = LDWMIN
      IF ( INIT1 ) THEN
         IW1 = ML
         IW2 = MAX( MNO + N, M*LDAC )
      ELSE
         IW1 = 0
         IW2 = 0
      END IF
      IF ( INIT2 ) THEN
         IW3 = 3 + MAX( BSN + 1, LX + L )
      ELSE
         IW3 = 3 + LX + L
      END IF
      LIWORK = MAX( IW1, IW2, IW3 )
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE ( DWORK( LDWORK ), IWORK( LIWORK ), U( LDU, M ),
     $           X( LX ), Y( NSMP, L ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), U, NSMP*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), Y, NSMP*L )
      IF ( LPAR0.GT.0 )
     $   CALL mxCopyPtrToReal8( mxGetPr( PRHS(IX) ), X(INI), LPAR0 )
C
C Copy the seed for random numbers generation.
C
      IF ( INIT2 )
     $   CALL DCOPY( 4, RSEED, 1, DWORK, 1 )
      IF ( NS.LT.0 )
     $   N = NS
C
C Do the actual computations.
C
      CALL IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2,
     $             NPRINT, U, LDU, Y, LDY, X, LX, TOL1, TOL2,
     $             IWORK, DWORK, LDWORK, IWARN, INFO )
C
C Copy output to MATLAB workspace.
C
      NX = L1 + N*( L + M + 1 ) + L*M
      PLHS(1) = mxCreateDoubleMatrix( NX, 1, 0 )
      CALL mxCopyReal8ToPtr( X, mxGetPr( PLHS(1) ), NX )
      IF ( NLHS.GT.1 ) THEN
         IF ( INIT2 ) THEN
            ISIZE = 8
         ELSE
            ISIZE = 4
         END IF
         PLHS(2) = mxCreateDoubleMatrix( ISIZE, 1, 0 )
         CALL mxCopyReal8ToPtr( DWORK, mxGetPr( PLHS(2) ), ISIZE )
      END IF
      IF ( NLHS.GT.2 ) THEN
         PLHS(3)  = mxCreateDoubleMatrix( 2, 1, 0 )
         DWORK(1) = IWORK(1)
         DWORK(2) = IWORK(2)
         CALL mxCopyReal8ToPtr( DWORK, mxGetPr( PLHS(3) ), 2 )
      END IF
      IF ( NLHS.GT.3 .AND. INIT1 ) THEN
         ISIZE   = IWORK(3)
         PLHS(4) = mxCreateDoubleMatrix( ISIZE, 1, 0 )
         CALL mxCopyReal8ToPtr( DWORK(9), mxGetPr( PLHS(4) ), ISIZE )
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      DEALLOCATE( DWORK, IWORK, U, X, Y )
C
C Close the printing file.
C
      IF ( NPRINT.GT.0 )
     $   CLOSE( NOUT )
C
C Error and warning handling.
C
      IF ( IWARN.NE.0 .AND. PRINTW ) THEN
         WRITE( TEXT, '(''  IWARN = '',I4,'' ON EXIT FROM IB03BD'')'
     $        ) IWARN
         CALL mexPrintf( TEXT )
      END IF
C
      IF ( INFO.NE.0 ) THEN
         WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM IB03BD'')'
     $        ) INFO
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of WIDENT ***
      END


	PROGRAM POLARPA
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
	COMPLEX CGAIN
C
	DO N = 1,10
	  F = N*2.E4
C	  PA(F)
	  PRINT*,F,PA(F),CGAIN,57.3*PHASE
	ENDDO
	STOP
	END
	FUNCTION PA(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE POLAR PREAMP.  THE SIGNAL
C	IS ASSUMED TO BE INJECTED AT THE SHEATH-PLASMA INTERFACE.
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2,ZIN,VSIG,VSH,VSP,GNOPAMP
C	R AND C OF SHEATHS AROUND SPHERE (SP) AND STUB (ST)
	DATA RSP,CSP,RST,CST /1.E7,10.E-12,1.E6,100.E-12/
C	DC GAIN AND GAIN-BANDWIDTH PRODUCT OF OPAMP
	DATA GOPAMP,GBWOPAMP /1.E6,1.E6/
	DATA RIN /80.E6/
	DATA R9,C9,R10,CINP /5.E8, 23.6E-12, 5.E8, 4.37E-12/
	DATA R33,C16 /2.2E+03, 1.203E-9/
	DATA R1C,R2C,CCOMP / 0., 4.64E3, .947E-6/
	DATA R5 /22.1E3/
	DATA TWOPI /6.2831853/
C
	W = TWOPI*F
	CGAIN = 1.
C	COMPLEX GAIN OF OP AMP
	GNOPAMP = GOPAMP/CMPLX(1., W*GOPAMP/GBWOPAMP)
C	GAIN WITH FEEDBACK
	GNOPAMP = GOPAMP/CMPLX((1. + GOPAMP), W*GOPAMP/GBWOPAMP)
C	SPHERE SHEATH IMPEDANCE
	Z1 = RSP/CMPLX(1., W*RSP*CSP)
	ZIN = CMPLX(RIN,0.)
	VSP = CGAIN*ZIN/(ZIN+Z1)
	CGAIN = VSP*GNOPAMP
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	PA = CABS(CGAIN)
	RETURN
	END


 SUBROUTINE POLATES4(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
                     MI,MO,KM,IBI,GI, &
                     NO,RLAT,RLON,IBO,LO,GO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATES4   INTERPOLATE SCALAR FIELDS (SPECTRAL)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS SPECTRAL INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR SCALAR FIELDS.
!           IT REQUIRES THAT THE INPUT FIELDS BE UNIFORMLY GLOBAL.
!           OPTIONS ALLOW CHOICES BETWEEN TRIANGULAR SHAPE (IPOPT(1)=0)
!           AND RHOMBOIDAL SHAPE (IPOPT(1)=1) WHICH HAS NO DEFAULT;
!           A SECOND OPTION IS THE TRUNCATION (IPOPT(2)) WHICH DEFAULTS
!           TO A SENSIBLE TRUNCATION FOR THE INPUT GRID (IF OPT(2)=-1).
!           NOTE THAT IF THE OUTPUT GRID IS NOT FOUND IN A SPECIAL LIST,
!           THEN THE TRANSFORM BACK TO GRID IS NOT VERY FAST.
!           THIS SPECIAL LIST CONTAINS GLOBAL CYLINDRICAL GRIDS,
!           POLAR STEREOGRAPHIC GRIDS CENTERED AT THE POLE
!           AND MERCATOR GRIDS. ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!
!           THE CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMO  =01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMO  =10) MERCATOR CYLINDRICAL
!             (IGDTNUMO  =20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMO  =30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED.
!           ON THE OTHER HAND, THE OUTPUT CAN BE A SET OF STATION POINTS
!           IF IGDTNUMO<0, IN WHICH CASE THE NUMBER OF POINTS
!           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT.
!           OUTPUT BITMAPS WILL NOT BE CREATED.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 2001-06-18  IREDELL  IMPROVE DETECTION OF SPECIAL FAST TRANSFORM
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      VERSION OF GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATES4(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
!                         MI,MO,KM,IBI,LI,GI, &
!                         NO,RLAT,RLON,IBO,LO,GO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1)=0 FOR TRIANGULAR, IPOPT(1)=1 FOR RHOMBOIDAL;
!                IPOPT(2) IS TRUNCATION NUMBER
!                (DEFAULTS TO SENSIBLE IF IPOPT(2)=-1).
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE. IGDTNUMO<0
!                MEANS INTERPOLATE TO RANDOM STATION POINTS.
!                OTHERWISE, SAME DEFINITION AS "IGDTNUMI".
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS (MUST BE ALL 0)
!     GI       - REAL (MI,KM) INPUT FIELDS TO INTERPOLATE
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO<0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO<0)
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO>=0)
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO>=0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO>=0)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     GO       - REAL (MO,KM) OUTPUT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!                41   INVALID NONGLOBAL INPUT GRID
!                42   INVALID SPECTRAL METHOD PARAMETERS
!
! SUBPROGRAMS CALLED:
!   EARTH_RADIUS DETERMINE SIZE/SHAPE OF EARTH
!   GDSWZD       GRID DESCRIPTION SECTION WIZARD
!   SPTRUN       SPECTRALLY TRUNCATE GRIDDED SCALAR FIELDS
!   SPTRUNS      SPECTRALLY INTERPOLATE SCALARS TO POLAR STEREO.
!   SPTRUNM      SPECTRALLY INTERPOLATE SCALARS TO MERCATOR
!   SPTRUNG      SPECTRALLY INTERPOLATE SCALARS TO STATIONS
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,          INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,          INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,          INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,          INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
 INTEGER,          INTENT(IN   ) :: IPOPT(20)
 INTEGER,          INTENT(IN   ) :: MI, MO
 INTEGER,          INTENT(IN   ) :: IBI(KM), KM
 INTEGER,          INTENT(  OUT) :: IBO(KM), IRET, NO
!
 LOGICAL*1,        INTENT(  OUT) :: LO(MO,KM)
!
 REAL,             INTENT(IN   ) :: GI(MI,KM)
 REAL,             INTENT(INOUT) :: RLAT(MO),RLON(MO)
 REAL,             INTENT(  OUT) :: GO(MO,KM)
!
 REAL,             PARAMETER     :: FILL=-9999.
 REAL,             PARAMETER     :: PI=3.14159265358979
 REAL,             PARAMETER     :: DPR=180./PI
!
 INTEGER                         :: IDRTI, IDRTO, IG, JG, IM, JM
 INTEGER                         :: IGO, JGO, IMO, JMO
 INTEGER                         :: ISCAN, JSCAN, NSCAN
 INTEGER                         :: ISCANO, JSCANO, NSCANO
 INTEGER                         :: ISKIPI, JSKIPI, ISCALE
 INTEGER                         :: IMAXI, JMAXI, ISPEC
 INTEGER                         :: IP, IPRIME, IPROJ, IROMB, K
 INTEGER                         :: MAXWV, N, NI, NJ, NPS
!
 REAL                            :: DE, DR, DY
 REAL                            :: DLAT, DLON, DLATO, DLONO
 REAL                            :: GO2(MO,KM), H, HI, HJ
 REAL                            :: ORIENT, SLAT, RERTH, E2
 REAL                            :: RLAT1, RLON1, RLAT2, RLON2, RLATI
 REAL                            :: XMESH, XP, YP
 REAL                            :: XPTS(MO), YPTS(MO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
 IRET=0
 IF(IGDTNUMO.GE.0) THEN
   CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO)
   IF(NO.EQ.0) IRET=3
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  AFFIRM APPROPRIATE INPUT GRID
!    LAT/LON OR GAUSSIAN
!    NO BITMAPS
!    FULL ZONAL COVERAGE
!    FULL MERIDIONAL COVERAGE
 IDRTI=IGDTNUMI
 IF(IDRTI==40) IDRTI=4
 IF(IDRTI==0.OR.IDRTI==4)THEN
   IM=IGDTMPLI(8)
   JM=IGDTMPLI(9)
   ISCALE=IGDTMPLI(10)*IGDTMPLI(11)
   IF(ISCALE==0) ISCALE=10**6
   RLON1=FLOAT(IGDTMPLI(13))/FLOAT(ISCALE)
   RLON2=FLOAT(IGDTMPLI(16))/FLOAT(ISCALE)
   ISCAN=MOD(IGDTMPLI(19)/128,2)
   JSCAN=MOD(IGDTMPLI(19)/64,2)
   NSCAN=MOD(IGDTMPLI(19)/32,2)
 ELSE
   IRET=41
 ENDIF
 DO K=1,KM
   IF(IBI(K).NE.0) IRET=41
 ENDDO
 IF(IRET.EQ.0) THEN
   IF(ISCAN.EQ.0) THEN
     DLON=(MOD(RLON2-RLON1-1+3600,360.)+1)/(IM-1)
   ELSE
     DLON=-(MOD(RLON1-RLON2-1+3600,360.)+1)/(IM-1)
   ENDIF
   IG=NINT(360/ABS(DLON))
   IPRIME=1+MOD(-NINT(RLON1/DLON)+IG,IG)
   IMAXI=IG
   JMAXI=JM
   IF(MOD(IG,2).NE.0.OR.IM.LT.IG) IRET=41
 ENDIF
 IF(IRET.EQ.0.AND.IDRTI.EQ.0) THEN
   ISCALE=IGDTMPLI(10)*IGDTMPLI(11)
   IF(ISCALE==0) ISCALE=10**6
   RLAT1=FLOAT(IGDTMPLI(12))/FLOAT(ISCALE)
   RLAT2=FLOAT(IGDTMPLI(15))/FLOAT(ISCALE)
   DLAT=(RLAT2-RLAT1)/(JM-1)
   JG=NINT(180/ABS(DLAT))
   IF(JM.EQ.JG) IDRTI=256
   IF(JM.NE.JG.AND.JM.NE.JG+1) IRET=41
 ELSEIF(IRET.EQ.0.AND.IDRTI.EQ.4) THEN
   JG=IGDTMPLI(18)*2
   IF(JM.NE.JG) IRET=41
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 IF(IRET.EQ.0) THEN
   IROMB=IPOPT(1)
   MAXWV=IPOPT(2)
   IF(MAXWV.EQ.-1) THEN
     IF(IROMB.EQ.0.AND.IDRTI.EQ.4) MAXWV=(JMAXI-1)
     IF(IROMB.EQ.1.AND.IDRTI.EQ.4) MAXWV=(JMAXI-1)/2
     IF(IROMB.EQ.0.AND.IDRTI.EQ.0) MAXWV=(JMAXI-3)/2
     IF(IROMB.EQ.1.AND.IDRTI.EQ.0) MAXWV=(JMAXI-3)/4
     IF(IROMB.EQ.0.AND.IDRTI.EQ.256) MAXWV=(JMAXI-1)/2
     IF(IROMB.EQ.1.AND.IDRTI.EQ.256) MAXWV=(JMAXI-1)/4
   ENDIF
   IF((IROMB.NE.0.AND.IROMB.NE.1).OR.MAXWV.LT.0) IRET=42
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE
 IF(IRET.EQ.0) THEN
   IF(NSCAN.EQ.0) THEN
     ISKIPI=1
     JSKIPI=IM
   ELSE
     ISKIPI=JM
     JSKIPI=1
   ENDIF
   IF(ISCAN.EQ.1) ISKIPI=-ISKIPI
   IF(JSCAN.EQ.0) JSKIPI=-JSKIPI
   ISPEC=0
!  SPECIAL CASE OF GLOBAL CYLINDRICAL GRID
   IF((IGDTNUMO.EQ.0.OR.IGDTNUMO.EQ.40).AND. &
       MOD(IGDTMPLO(8),2).EQ.0.AND.IGDTMPLO(13).EQ.0.AND.IGDTMPLO(19).EQ.0) THEN
     IDRTO=IGDTNUMO
     IF(IDRTO==40)IDRTO=4
     IMO=IGDTMPLO(8)
     JMO=IGDTMPLO(9)
     ISCALE=IGDTMPLO(10)*IGDTMPLO(11)
     IF(ISCALE==0) ISCALE=10**6
     RLON2=FLOAT(IGDTMPLO(16))/FLOAT(ISCALE)
     DLONO=(MOD(RLON2-1+3600,360.)+1)/(IMO-1)
     IGO=NINT(360/ABS(DLONO))
     IF(IMO.EQ.IGO.AND.IDRTO.EQ.0) THEN
       RLAT1=FLOAT(IGDTMPLO(12))/FLOAT(ISCALE)
       RLAT2=FLOAT(IGDTMPLO(15))/FLOAT(ISCALE)
       DLAT=(RLAT2-RLAT1)/(JMO-1)
       JGO=NINT(180/ABS(DLAT))
       IF(JMO.EQ.JGO) IDRTO=256
       IF(JMO.EQ.JGO.OR.JMO.EQ.JGO+1) ISPEC=1
     ELSEIF(IMO.EQ.IGO.AND.IDRTO.EQ.4) THEN
       JGO=IGDTMPLO(18)*2
       IF(JMO.EQ.JGO) ISPEC=1
     ENDIF
     IF(ISPEC.EQ.1) THEN
       CALL SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMO,JMO, &
                   KM,IPRIME,ISKIPI,JSKIPI,MI,0,0,MO,0,GI,GO)
     ENDIF
!  SPECIAL CASE OF POLAR STEREOGRAPHIC GRID
   ELSEIF(IGDTNUMO.EQ.20.AND. &
          IGDTMPLO(8).EQ.IGDTMPLO(9).AND.MOD(IGDTMPLO(8),2).EQ.1.AND. &
          IGDTMPLO(15).EQ.IGDTMPLO(16).AND.IGDTMPLO(18).EQ.64) THEN
     NPS=IGDTMPLO(8)
     RLAT1=FLOAT(IGDTMPLO(10))*1.E-6
     RLON1=FLOAT(IGDTMPLO(11))*1.E-6
     ORIENT=FLOAT(IGDTMPLO(14))*1.E-6
     XMESH=FLOAT(IGDTMPLO(15))*1.E-3
     IPROJ=MOD(IGDTMPLO(17)/128,2)
     IP=(NPS+1)/2
     H=(-1.)**IPROJ
     SLAT=FLOAT(ABS(IGDTMPLO(13)))*1.E-6
     CALL EARTH_RADIUS(IGDTMPLO,IGDTLENO,RERTH,E2)
     DE=(1.+SIN(SLAT/DPR))*RERTH
     DR=DE*COS(RLAT1/DPR)/(1+H*SIN(RLAT1/DPR))
     XP=1-H*SIN((RLON1-ORIENT)/DPR)*DR/XMESH
     YP=1+COS((RLON1-ORIENT)/DPR)*DR/XMESH
     IF(NINT(XP).EQ.IP.AND.NINT(YP).EQ.IP) THEN
       IF(IPROJ.EQ.0) THEN
         CALL SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NPS, &
                      IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, &
                      SLAT,XMESH,ORIENT,GI,GO,GO2)
       ELSE
         CALL SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NPS, &
                      IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, &
                      SLAT,XMESH,ORIENT,GI,GO2,GO)
       ENDIF
       ISPEC=1
     ENDIF
!  SPECIAL CASE OF MERCATOR GRID
   ELSEIF(IGDTNUMO.EQ.10) THEN
     NI=IGDTMPLO(8)
     NJ=IGDTMPLO(9)
     RLAT1=FLOAT(IGDTMPLO(10))*1.0E-6
     RLON1=FLOAT(IGDTMPLO(11))*1.0E-6
     RLON2=FLOAT(IGDTMPLO(15))*1.0E-6
     RLATI=FLOAT(IGDTMPLO(13))*1.0E-6
     ISCANO=MOD(IGDTMPLO(16)/128,2)
     JSCANO=MOD(IGDTMPLO(16)/64,2)
     NSCANO=MOD(IGDTMPLO(16)/32,2)
     DY=FLOAT(IGDTMPLO(19))*1.0E-3
     HI=(-1.)**ISCANO
     HJ=(-1.)**(1-JSCANO)
     CALL EARTH_RADIUS(IGDTMPLO,IGDTLENO,RERTH,E2)
     DLONO=HI*(MOD(HI*(RLON2-RLON1)-1+3600,360.)+1)/(NI-1)
     DLATO=HJ*DY/(RERTH*COS(RLATI/DPR))*DPR
     IF(NSCANO.EQ.0) THEN
       CALL SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NI,NJ, &
                    IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, &
                    RLAT1,RLON1,DLATO,DLONO,GI,GO)
       ISPEC=1
     ENDIF
   ENDIF
!  GENERAL SLOW CASE
   IF(ISPEC.EQ.0) THEN
     CALL SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NO, &
                  IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0,RLAT,RLON,GI,GO)
   ENDIF
   DO K=1,KM
     IBO(K)=0
     DO N=1,NO
       LO(N,K)=.TRUE.
     ENDDO
   ENDDO
 ELSE
   DO K=1,KM
     IBO(K)=1
     DO N=1,NO
       LO(N,K)=.FALSE.
       GO(N,K)=0.
     ENDDO
   ENDDO
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATES4