      subroutine dtrco(t,ldt,n,rcond,z,job)
      integer ldt,n,job
      double precision t(ldt,*),z(*)
      double precision rcond
c
c     dtrco estimates the condition of a double precision triangular
c     matrix.
c
c     on entry
c
c        t       double precision(ldt,n)
c                t contains the triangular matrix. the zero
c                elements of the matrix are not referenced, and
c                the corresponding elements of the array can be
c                used to store other information.
c
c        ldt     integer
c                ldt is the leading dimension of the array t.
c
c        n       integer
c                n is the order of the system.
c
c        job     integer
c                = 0         t  is lower triangular.
c                = nonzero   t  is upper triangular.
c
c     on return
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  t .
c                for the system  t*x = b , relative perturbations
c                in  t  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  t  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  t  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,dasum
c     fortran dabs,dmax1,dsign
c
c     internal variables
c
      double precision w,wk,wkm,ek
      double precision tnorm,ynorm,s,sm,dasum
      integer i1,j,j1,j2,k,kk,l
      logical lower
c
      lower = job .eq. 0
c
c     compute 1-norm of t
c
      tnorm = 0.0d0
      do 10 j = 1, n
         l = j
         if (lower) l = n + 1 - j
         i1 = 1
         if (lower) i1 = j
         tnorm = dmax1(tnorm,dasum(l,t(i1,j),1))
   10 continue
c
c     rcond = 1/(norm(t)*(estimate of norm(inverse(t)))) .
c     estimate = norm(z)/norm(y) where  t*z = y  and  trans(t)*y = e .
c     trans(t)  is the transpose of t .
c     the components of  e  are chosen to cause maximum local
c     growth in the elements of y .
c     the vectors are frequently rescaled to avoid overflow.
c
c     solve trans(t)*y = e
c
      ek = 1.0d0
      do 20 j = 1, n
         z(j) = 0.0d0
   20 continue
      do 100 kk = 1, n
         k = kk
         if (lower) k = n + 1 - kk
         if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
         if (dabs(ek-z(k)) .le. dabs(t(k,k))) go to 30
            s = dabs(t(k,k))/dabs(ek-z(k))
            call dscal(n,s,z,1)
            ek = s*ek
   30    continue
         wk = ek - z(k)
         wkm = -ek - z(k)
         s = dabs(wk)
         sm = dabs(wkm)
         if (t(k,k) .eq. 0.0d0) go to 40
            wk = wk/t(k,k)
            wkm = wkm/t(k,k)
         go to 50
   40    continue
            wk = 1.0d0
            wkm = 1.0d0
   50    continue
         if (kk .eq. n) go to 90
            j1 = k + 1
            if (lower) j1 = 1
            j2 = n
            if (lower) j2 = k - 1
            do 60 j = j1, j2
               sm = sm + dabs(z(j)+wkm*t(k,j))
               z(j) = z(j) + wk*t(k,j)
               s = s + dabs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               w = wkm - wk
               wk = wkm
               do 70 j = j1, j2
                  z(j) = z(j) + w*t(k,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve t*z = y
c
      do 130 kk = 1, n
         k = n + 1 - kk
         if (lower) k = kk
         if (dabs(z(k)) .le. dabs(t(k,k))) go to 110
            s = dabs(t(k,k))/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  110    continue
         if (t(k,k) .ne. 0.0d0) z(k) = z(k)/t(k,k)
         if (t(k,k) .eq. 0.0d0) z(k) = 1.0d0
         i1 = 1
         if (lower) i1 = k + 1
         if (kk .ge. n) go to 120
            w = -z(k)
            call daxpy(n-kk,w,t(i1,k),1,z(i1),1)
  120    continue
  130 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (tnorm .ne. 0.0d0) rcond = ynorm/tnorm
      if (tnorm .eq. 0.0d0) rcond = 0.0d0
      return
      end


!!# FUNCTION MODULE: <FUN_xyINTEGRALF>
MODULE FUN_xyINTEGRALF

!!## PURPOSE
!! Integrates a general function $F$ over shapes in 2D.

!!## METHOD
!! A 19th order cubature given in TOMS 706.

!!## AUTHORS
! Jarle Berntsen, Terje Espelid

!!## REFERENCES
!
!    Jarle Berntsen, Terje Espelid,
!    Algorithm 706:
!    DCUTRI, an Algorithm for Adaptive Cubature over a Collection
!    of Triangles,
!    ACM Transactions on Mathematical Software,
!    Volume 18, Number 3, September 1992, pages 329-342.

!!## NOTES
!! Wrapped in a user-friendly function by W. A. Wieselquist [waw].

!!## EXTERNAL MODULES
USE KND_IntrinsicTypes                          !!((01-A-KND_IntrinsicTypes.f90))
USE SUB_dcutri                                  !!((03-A-SUB_dcutri.f90))
USE FUN_Default                                 !!((04-A-FUN_Default.f90))
USE FUN_xySAREA                                 !!((03-A-FUN_xySAREA.f90))
USE FUN_xyCENTROID                              !!((05-B-FUN_xyCENTROID.f90))
USE FUN_xyTRIANGULATE                           !!((07-B-FUN_xyTRIANGULATE.f90))
USE FUN_xyDIST                                  !!((04-B-FUN_xyDIST.f90))
USE FUN_xyDIRECTION                             !!((04-B-FUN_xyDIRECTION.f90))
USE FUN_Integrate1_aq                           !!((06-B-FUN_Integrate1_aq.f90))
USE FUN_Error                                   !!((04-A-FUN_Error.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALF_Trx
 MODULE PROCEDURE xyINTEGRALF_Trx_Rsp
 MODULE PROCEDURE xyINTEGRALF_Trx_Rdp
ENDINTERFACE
INTERFACE xyINTEGRALF_Tr
 MODULE PROCEDURE xyINTEGRALF_Tr_Rsp
 MODULE PROCEDURE xyINTEGRALF_Tr_Rdp
ENDINTERFACE
INTERFACE xyINTEGRALF_Pg
 MODULE PROCEDURE xyINTEGRALF_Pg_Rsp
 MODULE PROCEDURE xyINTEGRALF_Pg_Rdp
ENDINTERFACE
INTERFACE xyINTEGRALF_Ls
 MODULE PROCEDURE xyINTEGRALF_Ls_Rsp
 MODULE PROCEDURE xyINTEGRALF_Ls_Rdp
ENDINTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALF_Trx
PUBLIC :: xyINTEGRALF_Trx_Rsp
PUBLIC :: xyINTEGRALF_Trx_Rdp
PUBLIC :: xyINTEGRALF_Tr
PUBLIC :: xyINTEGRALF_Tr_Rsp
PUBLIC :: xyINTEGRALF_Tr_Rdp
PUBLIC :: xyINTEGRALF_Pg
PUBLIC :: xyINTEGRALF_Pg_Rsp
PUBLIC :: xyINTEGRALF_Pg_Rdp
PUBLIC :: xyINTEGRALF_Ls
PUBLIC :: xyINTEGRALF_Ls_Rsp
PUBLIC :: xyINTEGRALF_Ls_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!!### FUNCTION <xyINTEGRALF_Ls_Rsp>
FUNCTION xyINTEGRALF_Ls_Rsp( f , Ls , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rsp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Ls.f90.hdr"

!!--begin--
INCLUDE "08-A-FUN_xyINTEGRALF_Ls.f90.bdy"
!!--end--

END FUNCTION

!!### FUNCTION <xyINTEGRALF_Ls_Rdp>
FUNCTION xyINTEGRALF_Ls_Rdp( f , Ls , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rdp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Ls.f90.hdr"

!!--begin--
INCLUDE "08-A-FUN_xyINTEGRALF_Ls.f90.bdy"
!!--end--

END FUNCTION

!!### FUNCTION <xyINTEGRALF_Trx_Rdp>
FUNCTION xyINTEGRALF_Trx_Rdp( f , N , Trx , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rdp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Trx.f90.hdr"

!!--begin--

INCLUDE "08-A-FUN_xyINTEGRALF_Trx.f90.bdy"

!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRALF_Trx_Rsp>
FUNCTION xyINTEGRALF_Trx_Rsp( f , N , Trx , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rsp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Trx.f90.hdr"

!!--begin--

INCLUDE "08-A-FUN_xyINTEGRALF_Trx.f90.bdy"

!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRALF_Tr_Rsp>
FUNCTION xyINTEGRALF_Tr_Rsp( f , Tr , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rsp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Tr.f90.hdr"

!!--begin--
INCLUDE "08-A-FUN_xyINTEGRALF_Tr.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRALF_Tr_Rdp>
FUNCTION xyINTEGRALF_Tr_Rdp( f , Tr , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rdp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Tr.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyINTEGRALF_Tr.f90.bdy"

!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRALF_Pg_Rsp>
FUNCTION xyINTEGRALF_Pg_Rsp( f , N , Pg , P_centroid , Area , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rsp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Pg.f90.hdr"

!!--begin--
INCLUDE "08-A-FUN_xyINTEGRALF_Pg.f90.bdy"
!!--end--

END FUNCTION

!!### FUNCTION <xyINTEGRALF_Tr_Rdp>
FUNCTION xyINTEGRALF_Pg_Rdp( f , N , Pg , P_centroid , Area , reltol , abstol , &
  nmin,nmax , err,num_eval,ierr ) RESULT(INTEGRALF)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-INT_Function2_Rdp.f90.hdr"
INCLUDE "08-A-FUN_xyINTEGRALF_Pg.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyINTEGRALF_Pg.f90.bdy"

!!--end--
END FUNCTION

END MODULE


\ Programme de visualisation d'algorithmes de tri.
\ 6 algorithmes : Bubble, Heap, Insert, Merge, Shell, Quick.

S" pixel.f" INCLUDED

160 CONSTANT nbr-elements
160 CONSTANT nbr-tirages

\ =============================
\ Genere la liste aleatoire
\ =============================

variable ensemble nbr-elements cells allot
variable elementA \ element arrivé
variable elementD \ element de départ
variable positionD \ position  départ
variable positionA \ position arrivé
variable compteur \ compteur pour analyse

: initialise-ensemble
	nbr-elements 1 - positionD !
	nbr-elements 0 do
	i ensemble i cells + !
	loop ;

: tire-une-element \ tire une element du paquet, memorise l'element et sa position
	positionD @ random dup cells ensemble + @ elementA ! positionA ! ;

: prend-element-dessus
	ensemble positionD @ cells + @ elementD ! ;

: inverse-elements \ inverse les elements dans la pile
	elementA @ ensemble positionD @ cells + !
	elementD @ ensemble positionA @ cells + ! ;

\ fonction principale

: melange
	nbr-tirages 0 do
	tire-une-element
	prend-element-dessus
	inverse-elements
	positionD @ 1 - positionD !
	loop ;

\ ================
\ Affichage
\ ================

: affichage
	nbr-elements 0 do
	i 2 * 0 i 2 * i cells ensemble + @ draw-line \ double la largeur de la ligne
	i 2 * 1 + 0 i 2 * 1 + i cells ensemble + @ draw-line
	loop view cls \ important de vider le buffer!
;

: animation ( pause -- )
	affichage
	compteur @ 1+ compteur !
	pause ;

\ ================
\ Bubble sort
\ ================

: inverse-bubble ( addr1 addr2 -- )
	dup cells ensemble + swap 1+ cells ensemble + swap
	over @ over @        ( read values )
	swap rot ! swap !   ( inverse range values )
    5 animation
;

: comparaison-bubble ( position --  position vpos vpos1+ ) \ compare avec la cellule un cran au dessus
	dup dup cells ensemble + @
	swap 1+ cells ensemble + @ ( 2dup )
	> if inverse-bubble else ( 2drop ) drop then
;

: bubble-sort
	nbr-elements 1- 0 do
	nbr-elements 1- i - 0 do
	i comparaison-bubble
  loop loop
;

\ ====================
\ Heap sort
\ ====================

: precede                         ( n1 n2 a -- f)
	>r cells r@ + @ swap cells r> + @ swap < ;

: inverser-heap ( n1 n2 a --)
	>r cells r@ + swap cells r> + over @ over @ swap rot ! swap !
	50 animation
;

: r'@ r> r> r@ swap >r swap >r ;

: Descendre ( a e s -- a e s)
  swap >r swap >r dup
  begin dup 2* 1+ dup r'@ <
  while
    dup 1+ dup r'@ <
    if over over r@ precede if swap then
    then drop over over r@ precede
  while
    tuck r@ inverser-heap
  repeat then drop drop r> swap r> swap
;

: Heap-sort ( -- )
  ensemble nbr-elements
  over >r dup 1- 1- 2/
  begin
    dup 0< 0=
  while
    Descendre 1- repeat drop 1- 0
  begin over 0 >
  while over over r@ inverser-heap
  Descendre swap 1- swap
  repeat drop drop drop r> drop ;

\ ====================
\ Shell sort
\ ====================

: Shell  ( adr n h -- adr n h)
  over >r tuck ?do
    i swap >r 2dup cells + @ -rot
    begin dup r@ - dup >r 0< 0=
    while
      -rot over over r@ cells + @
      < >r rot r>
	  25 animation
    while
      over r@ cells + @ >r
      2dup cells + r> swap ! drop r>
	  25 animation
    repeat then
    rot >r 2dup cells +
    r> swap ! r> drop drop r>
  loop r> swap
  25 animation ;

: Shell-sort
	ensemble nbr-elements
	dup begin dup 2 = if 2/ else 5 11 */
	then dup while Shell
	repeat drop 2drop ;

\ ================
\ Merge sort
\ ================

: merge-step ( r mid l -- r mid+ l+ )
  over @ over @ < if
    over @ >r
    2dup - over dup cell+ rot move
    r> over !
	50 animation
    >r cell+ 2dup = if rdrop dup else r>
  then
  then cell+

  ;

: merge ( r mid lt -- r l )
  dup >r begin 2dup > while merge-step repeat 2drop r> ;

: mid ( l r -- mid ) over - 2/ cell negate and + ; \ pour Merge et Quick

: sort ( r l -- r l )
  2dup cell+ > NOT if exit then
  swap 2dup mid recurse rot recurse merge
;

: Merge-sort ( -- )
ensemble nbr-elements
cells over + swap sort 2drop ;

\ ================
\ Quick sort
\ ================

: inverser    ( addr1 addr2 -- )
  over @ over @
  swap rot ! swap !
  50 animation
 ;

: partition ( l r -- l r r2 l2 )
  2dup mid @ >r ( r: pivot )
  2dup
  begin
    swap begin  dup @  r@  < while 1 cells+ repeat
    swap begin  r@ over @  < while 1 cells - repeat
    2dup > not if 2dup inverser  >r cell+ r> 1 cells -  then
    2dup >
  until
  r> drop
  ;

: qsort ( l r -- )
  partition  swap rot
  2dup < if recurse else 2drop then
  2dup < if recurse else 2drop then
  ;

: Quick-sort ( -- )
  ensemble nbr-elements
  dup 2 < if 2drop exit then  1- cells over + qsort ;

\ ====================
\ Insert sort
\ ====================

: insert ( start end -- start )
  dup @ >r
  begin 2dup <
  while
    r@ over cell- @ <
  while
    cell- dup @ over cell+ !
  repeat then r> swap !
  100 animation
  ;

: Insert-sort ( -- )
  ensemble nbr-elements
  1 ?do dup i cells + insert loop drop ;

\ ====================
\ Affichage
\ ====================

: initialisation
	set-screen
    0 compteur !
	initialise-ensemble
	melange ;

: B-sort
	initialisation
	cyan
	affichage
	1000 pause
	Bubble-sort
	cr ." Bubble sort : done after " compteur ? ." permutations."
	1000 pause ;

: H-sort
	initialisation
	0 75 100 color
	affichage
	1000 pause
	Heap-sort
	cr ." Heap sort : done after " compteur ? ." permutations."  ;

: S-sort
	initialisation
	Red
	affichage
	1000 pause
	Shell-sort
	cr ." Shell sort : done after " compteur ? ." permutations." ;

: M-sort
	initialisation
	100 20 100 color
	affichage
	1000 pause
	Merge-sort
	cr ." Merge sort : done after " compteur ? ." permutations." ;

: Q-sort
	initialisation
	green
	affichage
	1000 pause
	Quick-sort
	cr ." Quick sort : done after " compteur ? ." permutations."  ;

: I-sort
	initialisation
	yellow
	affichage
	1000 pause
	Insert-sort
	cr ." Insert sort : done after " compteur ? ." permutations." ;

: run
cr ." Six sorting algorithms!" cr
." For Bubble sort type : B-sort" cr
." For Shell sort type : S-sort" cr
." For Heap sort type : H-sort" cr
." For Merge sort type : M-sort" cr
." For Quick sort type : Q-sort" cr
." For Insert sort type : I-sort" cr ;

run


C NCLFORTSTART
      SUBROUTINE BINDATAAVG(NZ,ZLON,ZLAT,Z,ZMSG,MLON,NLAT,GLON,GLAT,
     +                      GBINKNT,IOPT,IER)
      IMPLICIT NONE
c                                             ; INPUT
      INTEGER NLAT,MLON,NZ,IOPT,IER
      DOUBLE PRECISION ZLON(NZ),ZLAT(NZ),Z(NZ),ZMSG
      DOUBLE PRECISION GLON(MLON),GLAT(NLAT)
c                                             ; OUTPUT
      DOUBLE PRECISION GBINKNT(MLON,NLAT,2)
C NCLEND

c NCL:   function bin_avg(zlon[*],zlat[*],z[*], glon[*], glat[*], opt )

      INTEGER K,NL,ML,IFLAG
      DOUBLE PRECISION DLAT,DLON,GLATBND,GLONBND

      IER = 0

      DLAT = ABS(GLAT(2)-GLAT(1))
      DLON = ABS(GLON(2)-GLON(1))

c error checking
      IF (DLAT.LT.0.0D0 .OR. DLON.LT.0.0D0) THEN
          IER = 1
      END IF
c                            check for equal lat spacing
      DO NL = 1,NLAT - 1
          IF (ABS(GLAT(NL+1)-GLAT(NL)).NE.DLAT) THEN
              IER = IER + 10
              GO TO 10
          END IF
      END DO
   10 CONTINUE
c                            check for equal lon spacing
      DO ML = 1,MLON - 1
          IF (ABS(GLON(2)-GLON(1)).NE.DLON) THEN
              IER = IER + 100
              GO TO 20
          END IF
      END DO
   20 CONTINUE
c                            set all msg if error
      IF (IER.NE.0) THEN
          DO NL = 1,NLAT
              DO ML = 1,MLON
                  GBINKNT(ML,NL,1) = ZMSG
                  GBINKNT(ML,NL,2) = ZMSG
              END DO
          END DO
          RETURN
      END IF
c                            initialize
      DO NL = 1,NLAT
          DO ML = 1,MLON
              GBINKNT(ML,NL,1) = 0.0D0
              GBINKNT(ML,NL,2) = 0.0D0
          END DO
      END DO
c                            ; monotonically {in/de}creasing
      IF ((GLAT(2)-GLAT(1)).GT.0.0D0) THEN
          IFLAG = 1
      ELSE
          IFLAG = -1
      END IF
      GLATBND = GLAT(1) - IFLAG*DLAT
      GLONBND = GLON(1) - DLON/2

      DO K = 1,NZ
          IF (Z(K).NE.ZMSG) THEN
              NL = ABS((ZLAT(K)-GLATBND)/DLAT) + 1
              ML = (ZLON(K)-GLONBND)/DLON + 1
              IF (NL.GT.0 .AND. NL.LE.NLAT .AND. ML.GT.0 .AND.
     +            ML.LE.MLON) THEN
                  GBINKNT(ML,NL,1) = GBINKNT(ML,NL,1) + Z(K)
                  GBINKNT(ML,NL,2) = GBINKNT(ML,NL,2) + 1
              END IF
          END IF
      END DO
c                                     compute bin average
      DO NL = 1,NLAT
          DO ML = 1,MLON
              IF (GBINKNT(ML,NL,2).GT.0.0D0) THEN
                  GBINKNT(ML,NL,1) = GBINKNT(ML,NL,1)/GBINKNT(ML,NL,2)
              ELSE
                  GBINKNT(ML,NL,1) = ZMSG
              END IF
          END DO
      END DO

      RETURN
      END


!!
!> @brief       Randomizes data from a single experiment
!!
!! Module to randomize experimental point values to create new
!! experimental points. These points are built to follow the same
!! pattern as old experimental values from the Granada database.
!! This module also randomizes databases using the function written
!! to randomize single experiments.
!!
!! @author      Marielle Elizabeth Duran
!!
      module randomize_exp
                use exp_data
                use precisions, only: dp
                use random_num, only: box_muller_num
                implicit none
                private
                public randomize_experiment, randomize_database, calc_stan_dev
                contains

!!
!> @brief       Creates new experimental values based on old points
!!
!! Function to form new experimental point values based on old
!! experimental point values and the random number generator subroutine.
!! The values for the old experimental point values are stored in the
!! array, point_values. The subroutine for the random number generator
!! is called within the do loop. New experimental point values are
!! calculated using the mean, the randomly generated number, and
!! standard deviation.
!!
!! @author      Marielle Elizabeth Duran
!!
                function randomize_experiment(old_exp) result(new_exp)
                        implicit none
                        type(nn_experiment), intent(in) :: old_exp
                        type(nn_experiment) :: new_exp
                        integer :: i
                        real(dp) :: num, mean, stan_dev
                        real(dp), dimension(SIZE(old_exp%data_points)) &
                                :: point_values !< array for old values
                        new_exp = old_exp
                        do i = 1, old_exp%n_data
                                mean = old_exp%data_points(i)%value
                             stan_dev =old_exp%data_points(i)%stat_error
                           point_values(i) = old_exp%data_points(i)%value
                        call box_muller_num(num)
                           new_exp%data_points(i)%value = &
                                        mean + (num*stan_dev)
                        end do
                end function randomize_experiment

!!
!> @brief       Creates a database with randomly generated numbers
!!
!! Function to randomize a data base using the function,
!! randomize_experiment. That function randomizes a single experiment
!! and randomize_database puts each experiment into an array that
!! represents a database.
!!
!! @author      Marielle Elizabeth Duran
!!
                function randomize_database(old_data) result(new_data)
                        implicit none
               type(nn_experiment), dimension(:), intent(in) :: old_data
              type(nn_experiment), allocatable, dimension(:) :: new_data
                        integer :: i
                        allocate(new_data(1:SIZE(old_data)))
                        do i = 1, SIZE(old_data)
                         new_data(i) = randomize_experiment(old_data(i))
                        end do
                end function randomize_database

!!
!> @brief       Calculates mean value
!!
!! Function to calculate the mean of a generic array. This function was
!! not used but was saved.
!!
!! @author      Marielle Elizabeth Duran
!!
                function calc_mean(numbers) result(mean)
                        implicit none
                        real(dp) :: mean
                        real(dp), dimension( : ) :: numbers !< generic array
                        integer :: i, length
                        length = SIZE(numbers) !< size of array
                        mean = 0.0_dp
                        do i = 1, length
                                mean = mean + numbers(i)
                        end do
                        mean = mean/length
                end function calc_mean

!!
!> @brief       Calculates standard deviation
!!
!! Function to calculate the standard deviation of a generic array. This
!! function uses a function that calculates the mean of a generic array
!! so that it is possible to calculate the standard deviation.
!!
!! @author      Marielle Elizabeth Duran
!!
                function calc_stan_dev(numbers) result(stan_dev)
                        implicit none
                        real(dp) :: variance, stan_dev, mean
                        real(dp), dimension( : ) :: numbers !< generic array
                        integer :: i, length
                        length = SIZE(numbers) !< size of array
                        variance = 0.0_dp
                        mean = calc_mean(numbers)
                        do i = 1, length
                                variance = variance + (&
                                        numbers(i) - mean)&
                                        **2.0_dp
                        end do
                        variance = variance / (length - 1)
                        stan_dev = SQRT(variance)
                end function calc_stan_dev

        end module randomize_exp


c
c This a driver to test FastLap V1.9 as a callable procedure from fortran.
c The driver illustrates how FastLap may be used for solving potential problems
c cast as the Green or single layer formulations.  An example field
c quantity computation is included as well.
c Input compatible with this driver can be generated by sphere.f if it is
c processed through c2fdata.  The former code generates the geometry for a
c sphere and supplies boundary conditions for the sphere translating in an
c infinite fluid.  The Green formulation is set up as a mixed Neumann and
c Dirichlet problem as dictated by the input file.  The single layer formulation
c is set up by setting the RHS vector to be the potential value supplied in
c the input file.  The exact solution (including the source strength) is
c known for this problem, so the error in the solution may be computed and
c is reported by this driver.
c
c Written in Modern Fortran by Korsmeyer, winter 1993.  (c) MIT 1993.
c
      implicit none
      integer size
      parameter (size=8192)
      character*300 line
      double precision x(3,4,size), poten(size), dbydnpoten(size),
     $     xcen(3,size), xcoll(3,size), xnrm(3,size), area(size),
     $     lhsvect(size), rhsvect(size)
      double precision cos_theta, sin_theta, cos_phi, sin_phi
      double precision DUM1(4,size), DUM2(4,size), DUM3(9,size),
     $     DUM4(4,size), gennorm(6,size)
      integer type(size), shape(size), dtype(size), dummy, job, fljob
      integer rhstype(size), lhstype(size), rhsindex(4,size),
     $     lhsindex(4,size)
      integer NULL, POINT_SOURCE, CONSTANT_SOURCE, CONSTANT_DIPOLE,
     $     LINEAR_SOURCE, LINEAR_DIPOLE
      data NULL, POINT_SOURCE, CONSTANT_SOURCE, CONSTANT_DIPOLE,
     $     LINEAR_SOURCE, LINEAR_DIPOLE /0, 1, 11, 12, 21, 22/
      character*80 title, filename
      double precision exact_sol(size)
      integer nummom, numlev, i, j, k, nlhs, nrhs, nsing
      integer call_count
      double precision error, max_diri, ave_diri, max_neum, ave_neum,
     $     max_error, ave_error, cnt_diri, cnt_neum, cnt_error, max_area
      data max_diri, ave_diri, max_neum, ave_neum, cnt_diri, cnt_neum,
     $     max_error, ave_error, cnt_error, max_area
     $     /10*0.0/
      integer fastlap
      external fastlap
      double precision tolpar, tol
      parameter (tolpar = 0.0001)
      integer numitr, maxitr
      data maxitr /32/
      tol = tolpar
      call_count = 0
c
c Query for run parameters and data file name.
c
c These are the things you can do with the driver:
c job = 0 == compute a field
c job = 1 == solve a Green formulation with mixed conditions.
c job = 2 == solve a single layer formulation.
c
c These are the distinctions fastlap makes:
c fljob = 0 == compute a field (RHS matrix)
c fljob = 1 == solve a problem with L and RHS matrices.
c fljob = 2 == solve a system with the identity as the RHS matrix.
c
      write(*,'(//''You can test the Green formulation, a single ''
     $     ''layer''/''formulation, the source formulation, or a ''
     $     ''field''/''computation.  If you use the input for ''
     $     ''the sphere''/''translating in an infinite fluid, ''
     $     ''there will be''/''error checking as the solution is ''
     $     ''known.  For''/''this case, the input file should be ''
     $     ''one written''/''by sphere.f and processed by ''
     $     ''c2fdata.''/''You may, of course, use your own ''
     $     ''input data.''/)')
      write(*,'(''Testing? ''/
     $     ''                   Field (0)''/
     $     ''                   Green (1)''/
     $     ''            Single Layer (2)''/
     $     ''      Source Formulation (3)''/
     $     ''   Repeated Single Layer (4)   ''$)')
      read(*,*) job
      write(*,'(''You can run up to '',i4,'' panels.''/)') size
      write(*,'(''Select expansion order and tree depth:  ''$)')
      read(*,*) nummom, numlev
      write(*,'(''Filename for input data?  ''$)')
      read(*,'(a80)') filename
      open(unit=20, file=filename, status='old')
      read(20,'(a80)') title
      write(*,'(''The header in this file is:''/a80)') title
c
c Read in panel data from a file and set the number of singularities (nsing)
c to be the number of panels.
c
      do i = 1,size
         read(20,'(i1)',end=1) shape(i)
      end do
 1    continue
      nsing = i - 1
      print *, 'Looking for ',nsing,' panels.'
      rewind(20)
      read(20,'(a80)') title
      do i = 1,nsing
         read(20,*) dummy,
     $        ((x(k,j,i),k=1,3),j=1,shape(i)),
     $        poten(i),dbydnpoten(i),type(i)
      end do
c
c Compute the collocation points as the centroids of panels.
c
      call centroid(nsing,x,shape,DUM1,DUM2,xcen,DUM3,
     $     area,DUM4,gennorm)
c
c Here we Scramble the collocation points to test the dis-association of
C field point and singularity ordering.  All we do is reverse the point
c listing.  Obviously various schemes can be used to scramble the points,
c a random int with bubble sort would be nice...  The following was used just
c to see it work at all.  Note that O(N) algorithms differ from O(N^2) on
c this issue.  Try to forget about the O(N^2) ordering of the linear system
c that you are used to where the self influence shows up on the diagonal,
c here it is immaterial.  Take the 3 cases:
c GREEN:  With both left- and right-hand side matrices, the left- and
c right-hand side strength indices map the strengths to the singularities and
c these determine how to decode the solution.  The location (or order)
c for the collocation points doesn't make any difference.
c INDIRECT:  This case is more restrictive.  Here, the right-hand side
c vector is a condition at a specific collocation point, so the odering
c of the input right-hand side vector must conform to the collocation point
c ordering, while the output left-hand side vector will conform to the
c left-hand side strength indices.
c FIELD:  The restriction is similar here.  The input right-hand side
c vector is mapped to the singularities by the right-hand side strength
c indices, while the output left-hand side vector will be ordered to
c conform to the field point locations.
c In the cases below, you can see how the scrambling of the field point
c locations affects the other input to fastlap.
c
      j = nsing + 1
      do i = 1, nsing
c
c Reverses order of collocation points wrt panels:
c
c         j = j - 1
c
c Leaves collocation points in same order as panels:
c
         j = i
         xcoll(1,j) = xcen(1,i)
         xcoll(2,j) = xcen(2,i)
         xcoll(3,j) = xcen(3,i)
c
c We set the field point normal as the panel normal, but the
c routine we called for the normal gave us the normal pointing
c into the computational domain and we want it to point out, so
c we flip the sign.
c
         xnrm(1,j) = -gennorm(1,i)
         xnrm(2,j) = -gennorm(2,i)
         xnrm(3,j) = -gennorm(3,i)
C
C We initialize the derivative request to zero.
C
         dtype(i) = 0
      end do
c
c Save the exact solution for comparison with computed solution, and
c set the panel left- and right-hand side types and indices to the
c left- and right-hand side vectors.  N.B. You have to set the signs
c properly for the equation you wish to solve!!
c
c Allowed types are:
c               NULL               0   (not implemented)
c               CONSTANT_SOURCE   11
c               CONSTANT_DIPOLE   12
c               LINEAR_SOURCE     21   (not implemented)
c               LINEAR_DIPOLE     22   (not implemented)
c               POINT_SOURCE       1
c               POINT_DIPOLE       2   (not implemented)
c	        VORTEX_BLOB        3   (not implemented)
c
c
c This is a continuation point for a repeated single-layer formulation
c job. (job #4)
c
 4    continue
c
c This is a Green formulation:
c
      if (job .eq. 1) then
         fljob = 1
         nlhs = nsing
         nrhs = nsing
c
c This is the translating sphere N/D problem (like the input).
c
         do i = 1,nsing
            if(type(i) .eq. 0) then
c
c This is a panel on the dirichlet surface:
c
               rhstype(i) = CONSTANT_DIPOLE
               lhstype(i) = CONSTANT_SOURCE
c
c The following values are independent of where we collocate:
c
               exact_sol(i) = dbydnpoten(i)
c
c The vector is set to - the boundary condition to force the
c sign on the matrix-vector product.  The solution is decoded
c similarly below.
c
               rhsvect(i) = -poten(i)
               rhsindex(1,i) = i
               lhsindex(1,i) = i
            else if(type(i) .eq. 1) then
c
c This is a panel on the neumann surface:
c
               rhstype(i) = CONSTANT_SOURCE
               lhstype(i) = CONSTANT_DIPOLE
c
c The following values are independent of where we collocate:
c
               exact_sol(i) = poten(i)
               rhsvect(i) = dbydnpoten(i)
               rhsindex(1,i) = i
               lhsindex(1,i) = i
            else
               write(*,'(''driverf: missing a boundary type.'')')
               stop
            end if
         end do
c
c This is a single layer formulation for the translating sphere.
c
      else if ((job .eq. 2) .or. (job .eq. 4)) then
         fljob = 2
         nlhs = nsing
         nrhs = nsing
c
         do i = 1,nsing
c
c rhstype is meaningless here as this formulation has no RHS matrix, but
c we need to supply a legal type anyway.
c
            rhstype(i) = CONSTANT_SOURCE
            lhstype(i) = CONSTANT_SOURCE
c
c The solution is known in closed form.  We let xcen(3,i) be cos(theta).
c
            exact_sol(i) = -(3./(8.*3.141459265))*xcen(3,i)
            rhsvect(i) =  -(1./2.) * xcen(3,i)
            rhsindex(1,i) = i
            lhsindex(1,i) = i
         end do
c
c This is a source formulation for the translating sphere.
c
      else if (job .eq. 3) then
         fljob = 2
         nlhs = nsing
         nrhs = nsing

         do i = 1,nsing
c
c rhstype is meaningless here as this formulation has no RHS matrix, but
c we need to supply a legal type anyway.
c
            rhstype(i) = CONSTANT_SOURCE
            lhstype(i) = CONSTANT_SOURCE
            dtype(i) = 1
c
c The solution is known in closed form.  We let xcen(3,i) be cos(theta).
c
            exact_sol(i) = -(3./(8.*3.141459265))*xcen(3,i)
            rhsvect(i) =  -xcen(3,i)
            rhsindex(1,i) = i
            lhsindex(1,i) = i
         end do
c
c This is a field computation with the number of field points different
c from the number of singularities (it can be greater or less).
c
      else if (job .eq. 0) then
         fljob = 0
         nrhs = nsing
         nlhs = nsing
c
c This is the translating sphere single-layer formulation.
c
         do i = 1,nsing
            rhstype(i) = CONSTANT_SOURCE
c
c lhstype is meaningless here as this computation has no LHS matrix, but
c we need to supply a legal type anyway.
c
            lhstype(i) = CONSTANT_SOURCE
c the solution depends on where we collocate, the input rhsvect does not:
            exact_sol(i) = -(1./2.)*xcoll(3,i)
            rhsvect(i) = -(3./(8.*3.141459265))*xcen(3,i)
            rhsindex(1,i) = i
            lhsindex(1,i) = i
         end do
c
c Here we compress the existing field point vector to half its length,
c leaving out every other point.
c
c         nlhs = nsing / 2
c         do i = 1, nlhs
c            exact_sol(i) = exact_sol(2*i - 1)
c            do j = 1,3
c               xcoll(j,i) = xcoll(j,2*i - 1)
c            end do
c         end do
c
c Here we choose a few field points off the sphere.
c
         nlhs = 6
         do i = 1,nlhs
            cos_theta = xcen(3,i*10)
            sin_theta = sqrt(1.0 - cos_theta*cos_theta)
            cos_phi = xcen(1,i*10) / sin_theta
            sin_phi = sqrt(1.0 - cos_phi*cos_phi)
            xcoll(1,i) = 1.2 * sin_theta * cos_phi
            xcoll(2,i) = 1.2 * sin_theta * sin_phi
            xcoll(3,i) = 1.2 * cos_theta
            exact_sol(i) =  -(1./2.)*cos_theta/(1.2*1.2)
         end do
c
c Here we extend the existing field point vector to its length plus
c half again by just duplicating points.
c
c         nlhs = nsing + nsing / 2
c         do i = nsing + 1, nlhs
c            exact_sol(i) = exact_sol(i - nsing)
c            do j = 1,3
c               xcoll(j,i) = xcoll(j,i - nsing)
c            end do
c         end do
      end if
c
c Call fastlap to compute a solution or field at the vector of field points.
c
      numitr = fastlap(nlhs,nrhs,nsing,x,shape,dtype,lhstype,rhstype,
     $     lhsindex,rhsindex,lhsvect,rhsvect,xcoll,xnrm,numlev,nummom,
     $     maxitr,tol,fljob)
      write(*,'(//i3,
     $     '' iterations knocked down residual to:'',e14.8)')
     $     numitr, tol
c
c We set up repeated calls here to test that memory is freed.
c
      if (job .eq. 4) then
         call_count = call_count + 1
         write(*,'(/''*#*#*#* FastLap call number:'',i4/)') call_count
         tol = tolpar
         do i = 1,nlhs
            lhsvect(i) = 0.0
         end do
         go to 4
      end if
c
c Asess the solution for the various options.  We measure the
c point-wise error of the solution and the exact solution and
c then normalize by the area of the panel upon which the point
c resides.  This provides an error metric that would track the
c convergence of an integrated quantity like added mass or
c capacitance.
c
      open(unit=99,file='driver.out',status='unknown')
      write(99,'(''    xcoll(1,i)  xcoll(2,i)  xcoll(3,i)
     $   exact(i)    rhsvect(i)  lhsvect(i)'')')
      if (job .eq. 1) then
c
c Compute max and average errors on the Neumann and Dirichlet
c surfaces for the Green formulation.
c
         do i = 1,nlhs
            if(type(i) .eq. 0) then
c This is a panel on the dirichlet surface.  Note how we decode
c the solution due to the sign in the equation we are solving that
c fastlap has no way to know about.
               lhsvect(i) = -lhsvect(i)
               error = sqrt((exact_sol(i) - lhsvect(i))
     $              * (exact_sol(i) - lhsvect(i))) * area(i)
               max_diri = max(max_diri,error)
               ave_diri = ave_diri + error
               cnt_diri = cnt_diri + 1.
               write(99,999) xcoll(1,i),xcoll(2,i),xcoll(3,i),
     $              exact_sol(i),rhsvect(i),lhsvect(i)
               max_area = max(max_area, area(i))
            else if(type(i) .eq. 1) then
c This is a panel on the neumann surface:
               error = sqrt((exact_sol(i) - lhsvect(i))
     $              * (exact_sol(i) - lhsvect(i))) * area(i)
               max_neum = max(max_neum,error)
               ave_neum = ave_neum + error
               cnt_neum = cnt_neum + 1.
               write(99,999) xcoll(1,i),xcoll(2,i),xcoll(3,i),
     $              exact_sol(i),rhsvect(i),lhsvect(i)
               max_area = max(max_area, area(i))
            end if
         end do
         if (cnt_diri .ne. 0) then
            ave_diri = ave_diri / cnt_diri
            write(*,'(//''Average absolute error on Dirichlet''
     $           '' surface ='',f13.8)') ave_diri/max_area
            write(*,'(''Maximum absolute error on Dirichlet''
     $           '' surface ='',f13.8)') max_diri/max_area
         end if
         if (cnt_neum .ne. 0) then
            ave_neum = ave_neum / cnt_neum
            write(*,'(''Average absolute error on Neumann''
     $           '' surface ='',f13.8)') ave_neum/max_area
            write(*,'(''Maximum absolute error on Neumann''
     $           '' surface ='',f13.8)') max_neum/max_area
         end if
c
      else if ((job .eq. 2) .or. (job .eq. 3) .or. (job .eq. 4))then
c
c Evaluate the errors for the single layer formulation.
c
         do i = 1,nlhs
            error = sqrt((exact_sol(i) - lhsvect(i))
     $           * (exact_sol(i) - lhsvect(i))) * area(i)
            max_error = max(max_error,error)
            ave_error = ave_error + error
            cnt_error = cnt_error + 1.
               write(99,999) xcoll(1,i),xcoll(2,i),xcoll(3,i),
     $              exact_sol(i),rhsvect(i),lhsvect(i)
            max_area = max(max_area, area(i))
         end do
         ave_error = ave_error / cnt_error
         write(*,'(//''Average absolute error on entire surface ='',
     $        f13.8)') ave_error/max_area
         write(*,'(''Maximum absolute error on entire surface ='',
     $        f13.8)') max_error/max_area
      else if (job .eq. 0) then
c
c Evaluate the errors for the field computation.
c
         do i = 1,nlhs
            error = sqrt((exact_sol(i) - lhsvect(i))
     $           * (exact_sol(i) - lhsvect(i))) *area(i)
            max_error = max(max_error,error)
            ave_error = ave_error + error
            cnt_error = cnt_error + 1.
            write(99,999) xcoll(1,i),xcoll(2,i),xcoll(3,i),
     $           exact_sol(i),rhsvect(i),lhsvect(i)
               max_area = max(max_area, area(i))
         end do
         ave_error = ave_error / cnt_error
         write(*,'(//''Average absolute error on entire surface ='',
     $        f13.8)') ave_error/max_area
         write(*,'(''Maximum absolute error on entire surface ='',
     $        f13.8)') max_error/max_area
      end if
 999  format(3f12.6,4x,3f12.6,4x,f12.6)
      stop
      end


! A multiply-add: single-precision a*x + y aka saxpy
! using a parallel do construct
program main
    implicit none

contains
    subroutine saxpy(z, x, y, a, n)
        use omp_lib
        implicit none
        integer             :: iter
        integer, intent(in) :: n
        real, intent(in)    :: a, y, x(n)
        real, intent(out)   ::  z(n)

        !$omp parallel do private(iter) ! In Fortran, all index of interation (i.e. iter) are implicitly private by default
            do iter = 1, n
                z(iter) = a * x(iter) + y
            end do
        !$omp end parallel do
    end subroutine saxpy
end program main


module preserve_mean

   use shr_kind_mod, only : r8=>shr_kind_r8
!   use globals, only: nxo, nyo, ntime

   implicit none
   private
   public ::  monthly_to_midmonth
contains

subroutine monthly_to_midmonth (arr, nlev, nlonout,nxo,nyo,ntime)
!-------------------------------------------------------------------
!
!  Input/Output:
!     AEROSOL, M_ps_cam from monthly averages to mid-month values
!
!--------------------------------------------------------------------
!
! Arguments
!
   integer, intent(in) :: nlev
   integer, intent(in) :: nxo,nyo,ntime
   integer, intent(in) :: nlonout(nyo)
   real(r8), intent(inout) :: arr(nxo,nyo,nlev,ntime)  ! input/output array
!
! Local workspace
!
   real(r8) Matrix(1:12,1:12)   ! map from mid-month to monthly average
   integer pivot(12)            ! pivot from LU factor
   real(r8) vec(12)             ! vector to be used for LU solve
   integer i,j,k                ! spatial indices
   integer :: m                 ! constituent index
!
! ntime must be 12
!
   if (ntime /= 12) then
      write(6,*) 'monthly_to_midmonth: ntime must be 12 got ', ntime
      stop 999
   end if
!
! construct and factor linear map from
! mid month values to monthly averages
!
   call construct_matrix (Matrix, pivot)
!
! convert monthly averages to mid-month values
! could be sped up by solving many rhs at once
!  rather than one at a time.
!
   do k=1,nlev
      do j=1,nyo
         do i=1,nlonout(j)
            vec(:) = arr(i,j,k,:)
            call LUSolve (vec, Matrix, pivot)
            arr(i,j,k,:) = vec(:)
         end do
      end do
   end do

   return
end subroutine monthly_to_midmonth

subroutine construct_matrix (Matrix, pivot)
!--------------------------------------------------------------------
!  Input: None
!
!  Output:
!    Matrix (LU Factored form)
!    pivot (pivots corresponding to LU Factored form of matrix)
!
!  Method:
!    construct matrix representing averaging
!      from mid-monthly values
!      to monthly average values
!    factor matrix (matrix => LUFactoredMatrix, pivots) so that the
!      backsolves represent map from averages to mid-month values
!--------------------------------------------------------------------

  real(r8), intent(out) :: Matrix(12,12) !map from mid-month values to monthly average
  integer, intent(out) :: pivot(12) ! pivots from LU factorization of Matrix

  integer row, col, colp, colm  ! indexes ino matrix
  real(r8) :: Len(12)   ! number of days in month
  data Len /31.0, 28.0, 31.0, 30.0, 31.0, 30.0, 31.0, 31.0, 30.0, 31.0, 30.0, 31.0 /

  Matrix(:,:) = 0.0
!
! construct tridiagonal cyclic matrix
!
  do row = 1,12
    col  = row
    colm = row - 1
    colp = row + 1
    if (colm ==  0) then
      colm = 12
    endif
    if (colp == 13) then
      colp =  1
    endif
    Matrix(row,colm) = Len(row) / (4*(Len(row )+Len(colm)))
    Matrix(row,colp) = Len(row) / (4*(Len(colp)+Len(row )))
    Matrix(row,col ) = 1.0 - Matrix(row,colm) - Matrix(row,colp)
  enddo

  call LUFactor (Matrix, pivot);

  return
end subroutine construct_matrix

subroutine LUFactor (Matrix, pivot)
!-----------------------------------------------------------------
! interface to matrix factorization routine
!  here, LAPACK
!-----------------------------------------------------------------

  real(r8) Matrix(12,12) ! matrix to be factored
  integer pivot(12)      ! pivots from factorization
  integer :: info = 0    ! did factorization fail?

  call DGETRF (12, 12, Matrix, 12, pivot, info)
  if (info < 0) then
    write(6,*)"AEROSOL_INITIALIZE:DGETRF (LAPACK) factor argument ",-info," has illegal value"
    stop 999
  elseif(info > 0) then
    write(6,*)"AEROSOL_INITIALIZE:DGETRF (LAPACK) factor matrix upper element ",info," was zero"
    stop 999
  endif

  return
end subroutine LUFactor

subroutine LUSolve (vec, Matrix, pivot)
!-----------------------------------------------------------------
! interface to matrix back-solve routine
!  here, LAPACK
!-----------------------------------------------------------------

  real(r8)  vec(12)        ! vector to be solved.  vector then solution
  real(r8)  Matrix(12,12)  ! factored matrix
  integer  pivot(12)       ! pivots from factorization
  integer :: info = 0      ! did solve fail?

  call DGETRS ('N', 12, 1, Matrix, 12, pivot, vec, 12, info)
  if (info < 0) then
    write(6,*)"AEROSOL_INITIALIZE:DGETRS (LAPACK) solve argument ",-info," has illegal value"
    stop 999
  endif

  return
end subroutine LUSolve

end module preserve_mean


SUBROUTINE rk4_3d
  !
  USE basic
  USE numerics
  USE tracers
  USE fields
  !
  IMPLICIT NONE
  !
  ! Runge-Kutta 4th order method for position and velocity in
  ! 3 dimensions.
  !

  DOUBLE PRECISION :: tt,es_pot_B
  DOUBLE PRECISION, DIMENSION(ndim_tracer) :: accel, pos0,pos1,pos2,pos3, vel0,vel1,vel2,vel3, &
                                              dpos_1,dpos_2,dpos_3,dpos_4, dvel_1,dvel_2,dvel_3,dvel_4
  tt=tracerdeltat*0.5

  B_cart=0.
  E_cart=0.
  accel=0.

  pos0 = tracer_pos_cart(:,tracerid)
  vel0 = tracer_vel_cart(:,tracerid)

  pos_cart = pos0
  vel_cart = vel0

  rk_iter = 1

  ! find the first Runge-Kutta term
  CALL Bfieldfind ! uses pos_cart
  CALL Efieldfind ! uses pos_cart
  accel(1) = E_cart(1) + vel_cart(2)*B_cart(3) - vel_cart(3)*B_cart(2)
  accel(2) = E_cart(2) + vel_cart(3)*B_cart(1) - vel_cart(1)*B_cart(3)
  accel(3) = E_cart(3) + vel_cart(1)*B_cart(2) - vel_cart(2)*B_cart(1)

  dpos_1 = vel0
  dvel_1 = accel

  ! find the position for second RK4 term
  pos1 = pos0 + dpos_1*tt

  ! find the velocity for second RK4 term
  vel1 = vel0 + dvel_1*tt

  ! reset for next RK4 evaluation
  pos_cart = pos1
  B_cart=0.
  E_cart=0.
  accel=0.

  rk_iter = 2

  ! note: do not repeat the time interpolation...
  ! ...assume static field during a tracer time step...
  ! ...this is good to less than 1% for a GBS field KBG

  ! find the second Runge-Kutta term
  CALL Bfieldfind ! uses pos_cart
  CALL Efieldfind ! uses pos_cart
  accel(1) = E_cart(1) + vel1(2)*B_cart(3) - vel1(3)*B_cart(2)
  accel(2) = E_cart(2) + vel1(3)*B_cart(1) - vel1(1)*B_cart(3)
  accel(3) = E_cart(3) + vel1(1)*B_cart(2) - vel1(2)*B_cart(1)

  dpos_2 = vel1
  dvel_2 = accel

  ! find the position for the third Runge-Kutta term
  pos2 = pos0 + dpos_2*tt

  ! find the velocity for the third RK4 term
  vel2 = vel0 + dvel_2*tt

  ! reset for next field evaluation
  pos_cart = pos2
  B_cart=0.
  E_cart=0.
  accel=0.

  rk_iter = 3

  ! find the third Runge-Kutta term
  CALL Bfieldfind ! uses pos_cart
  CALL Efieldfind ! uses pos_cart
  accel(1) = E_cart(1) + vel2(2)*B_cart(3) - vel2(3)*B_cart(2)
  accel(2) = E_cart(2) + vel2(3)*B_cart(1) - vel2(1)*B_cart(3)
  accel(3) = E_cart(3) + vel2(1)*B_cart(2) - vel2(2)*B_cart(1)

  dpos_3 = vel2
  dvel_3 = accel

  ! find position for evaluating field for fourth RK4 accel term
  pos3 = pos0 + dpos_3*tracerdeltat

  ! find velocity for fourth RK4 position term
  vel3 = vel0 + dvel_3*tracerdeltat

  ! again, assume that the field is stationary across a
  ! tracer time step - this will not be good for all fields

  ! reset for next field evaluation
  pos_cart = pos3
  B_cart=0.
  E_cart=0.
  accel=0.

  rk_iter = 4

  ! find the fourth Runge-Kutta term
  CALL Bfieldfind ! uses pos_cart
  CALL Efieldfind ! uses pos_cart
  accel(1) = E_cart(1) + vel3(2)*B_cart(3) - vel3(3)*B_cart(2)
  accel(2) = E_cart(2) + vel3(3)*B_cart(1) - vel3(1)*B_cart(3)
  accel(3) = E_cart(3) + vel3(1)*B_cart(2) - vel3(2)*B_cart(1)

  dpos_4 = vel3
  dvel_4 = accel

  ! combine the guesses into the final answer for this particle, for this time step

  tracer_pos_cart(:,tracerid) = &
       pos0 + tracerdeltat*(dpos_1/6. + dpos_2/3. + dpos_3/3. + dpos_4/6.)

  tracer_vel_cart(:,tracerid) = &
       vel0 + tracerdeltat*(dvel_1/6. + dvel_2/3. + dvel_3/3. + dvel_4/6.)

!  tracer_pos_cart(2,tracerid) = &
!       pos0(2) + tracerdeltat*(dpos_1(2)/6. + dpos_2(2)/3. + dpos_3(2)/3. + dpos_4(2)/6.)
!
!  tracer_vel_cart(2,tracerid) = &
!       vel0(2) + tracerdeltat*(dvel_1(2)/6. + dvel_2(2)/3. + dvel_3(2)/3. + dvel_4(2)/6.)
!
!  tracer_pos_cart(3,tracerid) = &
!       pos0(3) + tracerdeltat*(dpos_1(3)/6. + dpos_2(3)/3. + dpos_3(3)/3. + dpos_4(3)/6.)
!
!  tracer_vel_cart(3,tracerid) = &
!       vel0(3) + tracerdeltat*(dvel_1(3)/6. + dvel_2(3)/3. + dvel_3(3)/3. + dvel_4(3)/6.)

END SUBROUTINE rk4_3d


      SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED,
     $                   TOLINF, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To check stability/antistability of finite eigenvalues with
C     respect to a given stability domain.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the stability domain as follows:
C             = 'C':  for a continuous-time system;
C             = 'D':  for a discrete-time system.
C
C     STDOM   CHARACTER*1
C             Specifies whether the domain of interest is of stability
C             type (left part of complex plane or inside of a circle)
C             or of instability type (right part of complex plane or
C             outside of a circle) as follows:
C             = 'S':  stability type domain;
C             = 'U':  instability type domain.
C
C     EVTYPE  CHARACTER*1
C             Specifies whether the eigenvalues arise from a standard
C             or a generalized eigenvalue problem as follows:
C             = 'S':  standard eigenvalue problem;
C             = 'G':  generalized eigenvalue problem;
C             = 'R':  reciprocal generalized eigenvalue problem.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of vectors ER, EI and ED.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             Specifies the boundary of the domain of interest for the
C             eigenvalues. For a continuous-time system
C             (DICO = 'C'), ALPHA is the boundary value for the real
C             parts of eigenvalues, while for a discrete-time system
C             (DICO = 'D'), ALPHA >= 0 represents the boundary value for
C             the moduli of eigenvalues.
C
C     ER, EI, (input) DOUBLE PRECISION arrays, dimension (N)
C     ED      If EVTYPE = 'S', ER(j) + EI(j)*i, j = 1,...,N, are
C             the eigenvalues of a real matrix.
C             ED is not referenced and is implicitly considered as
C             a vector having all elements equal to one.
C             If EVTYPE = 'G' or EVTYPE = 'R', (ER(j) + EI(j)*i)/ED(j),
C             j = 1,...,N, are the generalized eigenvalues of a pair of
C             real matrices. If ED(j) is zero, then the j-th generalized
C             eigenvalue is infinite.
C             Complex conjugate pairs of eigenvalues must appear
C             consecutively.
C
C     Tolerances
C
C     TOLINF  DOUBLE PRECISION
C             If EVTYPE = 'G' or 'R', TOLINF contains the tolerance for
C             detecting infinite generalized eigenvalues.
C             0 <= TOLINF < 1.
C
C     Error Indicator
C
C     INFO    INTEGER
C             =  0:  successful exit, i.e., all eigenvalues lie within
C                    the domain of interest defined by DICO, STDOM
C                    and ALPHA;
C             <  0:  if INFO = -i, the i-th argument had an illegal
C                    value;
C             =  1:  some eigenvalues lie outside the domain of interest
C                    defined by DICO, STDOM and ALPHA.
C     METHOD
C
C     The domain of interest for an eigenvalue lambda is defined by the
C     parameters ALPHA, DICO and STDOM as follows:
C        - for a continuous-time system (DICO = 'C'):
C               Real(lambda) < ALPHA if STDOM = 'S';
C               Real(lambda) > ALPHA if STDOM = 'U';
C        - for a discrete-time system (DICO = 'D'):
C               Abs(lambda) < ALPHA if STDOM = 'S';
C               Abs(lambda) > ALPHA if STDOM = 'U'.
C     If EVTYPE = 'R', the same conditions apply for 1/lambda.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, June 2001,
C     July 2020.
C
C     KEYWORDS
C
C     Stability.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, EVTYPE, STDOM
      INTEGER          INFO, N
      DOUBLE PRECISION ALPHA, TOLINF
C     .. Array Arguments ..
      DOUBLE PRECISION ED(*), EI(*), ER(*)
C     .. Local Scalars
      LOGICAL          DISCR, RECEVP, STAB, STDEVP
      DOUBLE PRECISION ABSEV, RPEV, SCALE
      INTEGER          I
C     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAPY2
      EXTERNAL         DLAPY2, LSAME
C     .. External Subroutines ..
      EXTERNAL         XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        ABS
C     .. Executable Statements ..
C
      INFO   = 0
      DISCR  = LSAME( DICO,   'D' )
      STAB   = LSAME( STDOM,  'S' )
      STDEVP = LSAME( EVTYPE, 'S' )
      RECEVP = LSAME( EVTYPE, 'R' )
C
C     Check the scalar input arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( STAB .OR. LSAME( STDOM, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( STDEVP .OR. LSAME( EVTYPE, 'G' ) .OR.
     $                 RECEVP ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN
         INFO = -5
      ELSE IF( TOLINF.LT.ZERO .OR. TOLINF.GE.ONE ) THEN
         INFO = -9
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09JX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      SCALE = ONE
C
      IF( STAB ) THEN
C
C        Check the stability of finite eigenvalues.
C
         IF( DISCR ) THEN
            DO 10 I = 1, N
               ABSEV = DLAPY2( ER(I), EI(I) )
               IF( RECEVP ) THEN
                  SCALE = ABSEV
                  ABSEV = ABS( ED(I) )
               ELSE IF( .NOT.STDEVP ) THEN
                  SCALE = ED(I)
               END IF
               IF( ABS( SCALE ).GT.TOLINF .AND.
     $            ABSEV.GE.ALPHA*SCALE ) THEN
                  INFO = 1
                  RETURN
               END IF
   10       CONTINUE
         ELSE
            DO 20 I = 1, N
               RPEV = ER(I)
               IF( RECEVP ) THEN
                  SCALE = RPEV
                  RPEV = ED(I)
               ELSE IF( .NOT.STDEVP ) THEN
                  SCALE = ED(I)
               END IF
               IF( ABS( SCALE ).GT.TOLINF .AND.
     $            RPEV.GE.ALPHA*SCALE ) THEN
                  INFO = 1
                  RETURN
               END IF
   20       CONTINUE
         END IF
      ELSE
C
C        Check the anti-stability of finite eigenvalues.
C
         IF( DISCR ) THEN
            DO 30 I = 1, N
               ABSEV = DLAPY2( ER(I), EI(I) )
               IF( RECEVP ) THEN
                  SCALE = ABSEV
                  ABSEV = ABS( ED(I) )
               ELSE IF( .NOT.STDEVP ) THEN
                  SCALE = ED(I)
               END IF
               IF( ABS( SCALE ).GT.TOLINF .AND.
     $            ABSEV.LE.ALPHA*SCALE ) THEN
                  INFO = 1
                  RETURN
               END IF
   30       CONTINUE
         ELSE
            DO 40 I = 1, N
               RPEV = ER(I)
               IF( RECEVP ) THEN
                  SCALE = RPEV
                  RPEV = ED(I)
               ELSE IF( .NOT.STDEVP ) THEN
                  SCALE = ED(I)
               END IF
               IF( ABS( SCALE ).GT.TOLINF .AND.
     $            RPEV.LE.ALPHA*SCALE ) THEN
                  INFO = 1
                  RETURN
               END IF
   40       CONTINUE
         END IF
      END IF
C
      RETURN
C *** Last line of AB09JX ***
      END


subroutine density(x,y,z,zmax,layer)
  !***subroutine to setup density grid***!
  !***for a given x,y,z, returns layer***!
  !***all distances in CM

  implicit none

  real*8 x,y,z

  real*8 sine,pi
  real*8 a,w
  real*8 b_epi_top, b_epi_mid, b_mel,b_basal,b_sc
  real*8 zmax
  real*8 um_to_cm
  integer layer

  !******calculate depths of layers from the surface of the skin
  !all distances in CM
  !**'wavelength' for sinosoidal undulation (dermal paillae)
  a=0.003  !amplitude
  w=0.0015!

  um_to_cm=0.0001

  sine=a*(SIN(x/w)*COS(y/w))

!Thicknesses TYPE I
! b_sc=zmax-(0.00148)
!
! b_epi_top=(2.d0/3.d0)*sine+(zmax-0.00565+a/2.d0)
! b_epi_mid=sine+(zmax-0.00765)
! b_mel=sine+(zmax-0.00865)
! b_basal=sine+(zmax-0.00965)

!Thicknesses TYPE VI
  b_sc=zmax-(0.00148)

  b_epi_top=(2.d0/3.d0)*sine+(zmax-0.00565+a/2.d0)
  b_epi_mid=sine+(zmax-0.00665)
  b_mel=sine+(zmax-0.00865)
  b_basal=sine+(zmax-0.00965)

    !for given x,y,z; return layer
  if (z.ge.b_sc)then
     layer=1
  elseif (z.ge.b_epi_top) then
     layer=2

  elseif (z.ge.b_epi_mid) then
     layer=3

  elseif (z.ge.b_mel) then
    layer=4

  elseif (z.ge.b_basal)then
     layer=5
  else
     layer=6
  endif

  return
end subroutine density


Function fnjet(x)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /njet/n, ipcrs
  Save
  omg1 = omg0(x)*hint1(11)/hipr1(31)
  c0 = exp(n*alog(omg1)-sgmin(n+1))
  If (n==0) c0 = 1.0 - exp(-2.0*omg0(x)*hipr1(30)/hipr1(31)/2.0)
  fnjet = c0*exp(-omg1)
  Return
End Function fnjet


*DECK DSOS
      SUBROUTINE DSOS (FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, RW, LRW,
     +   IW, LIW)
C***BEGIN PROLOGUE  DSOS
C***PURPOSE  Solve a square system of nonlinear equations.
C***LIBRARY   SLATEC
C***CATEGORY  F2A
C***TYPE      DOUBLE PRECISION (SOS-S, DSOS-D)
C***KEYWORDS  BROWN'S METHOD, NEWTON'S METHOD, NONLINEAR EQUATIONS,
C             ROOTS, SOLUTIONS
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     DSOS solves a system of NEQ simultaneous nonlinear equations in
C     NEQ unknowns.  That is, it solves the problem   F(X)=0
C     where X is a vector with components  X(1),...,X(NEQ)  and  F
C     is a vector of nonlinear functions.  Each equation is of the form
C
C               F (X(1),...,X(NEQ))=0     for K=1,...,NEQ.
C                K
C
C     The algorithm is based on an iterative method which is a
C     variation of Newton's method using Gaussian elimination
C     in a manner similar to the Gauss-Seidel process.  Convergence
C     is roughly quadratic.  All partial derivatives required by
C     the algorithm are approximated by first difference quotients.
C     The convergence behavior of this code is affected by the
C     ordering of the equations, and it is advantageous to place linear
C     and mildly nonlinear equations first in the ordering.
C
C     Actually, DSOS is merely an interfacing routine for
C     calling subroutine DSOSEQ which embodies the solution
C     algorithm.  The purpose of this is to add greater
C     flexibility and ease of use for the prospective user.
C
C     DSOSEQ calls the accompanying routine DSOSSL which solves special
C     triangular linear systems by back-substitution.
C
C     The user must supply a function subprogram which evaluates the
C     K-th equation only (K specified by DSOSEQ) for each call
C     to the subprogram.
C
C     DSOS represents an implementation of the mathematical algorithm
C     described in the references below.  It is a modification of the
C     code SOSNLE written by H. A. Watts in 1973.
C
C **********************************************************************
C   -Input-
C
C     FNC -Name of the function program which evaluates the equations.
C          This name must be in an EXTERNAL statement in the calling
C          program.  The user must supply FNC in the form FNC(X,K),
C          where X is the solution vector (which must be dimensioned
C          in FNC) and FNC returns the value of the K-th function.
C
C     NEQ -Number of equations to be solved.
C
C     X   -Solution vector.  Initial guesses must be supplied.
C
C     RTOLX -Relative error tolerance used in the convergence criteria.
C          Each solution component X(I) is checked by an accuracy test
C          of the form   ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX,
C          where XOLD(I) represents the previous iteration value.
C          RTOLX must be non-negative.
C
C     ATOLX -Absolute error tolerance used in the convergence criteria.
C          ATOLX must be non-negative.  If the user suspects some
C          solution component may be zero, he should set ATOLX to an
C          appropriate (depends on the scale of the remaining variables)
C          positive value for better efficiency.
C
C     TOLF -Residual error tolerance used in the convergence criteria.
C          Convergence will be indicated if all residuals (values of the
C          functions or equations) are not bigger than TOLF in
C          magnitude.  Note that extreme care must be given in assigning
C          an appropriate value for TOLF because this convergence test
C          is dependent on the scaling of the equations.  An
C          inappropriate value can cause premature termination of the
C          iteration process.
C
C     IFLAG -Optional input indicator.  You must set  IFLAG=-1  if you
C          want to use any of the optional input items listed below.
C          Otherwise set it to zero.
C
C     RW  -A DOUBLE PRECISION work array which is split apart by DSOS
C          and used internally by DSOSEQ.
C
C     LRW -Dimension of the RW array.  LRW must be at least
C                    1 + 6*NEQ + NEQ*(NEQ+1)/2
C
C     IW  -An INTEGER work array which is split apart by DSOS and used
C          internally by DSOSEQ.
C
C     LIW -Dimension of the IW array. LIW must be at least  3 + NEQ.
C
C   -Optional Input-
C
C     IW(1) -Internal printing parameter.  You must set  IW(1)=-1  if
C          you want the intermediate solution iterates to be printed.
C
C     IW(2) -Iteration limit.  The maximum number of allowable
C          iterations can be specified, if desired.  To override the
C          default value of 50, set IW(2) to the number wanted.
C
C     Remember, if you tell the code that you are using one of the
C               options (by setting IFLAG=-1), you must supply values
C               for both IW(1) and IW(2).
C
C **********************************************************************
C   -Output-
C
C     X   -Solution vector.
C
C     IFLAG -Status indicator
C
C                         *** Convergence to a Solution ***
C
C          1 Means satisfactory convergence to a solution was achieved.
C            Each solution component X(I) satisfies the error tolerance
C            test   ABS(X(I)-XOLD(I)) .LE. RTOLX*ABS(X(I))+ATOLX.
C
C          2 Means procedure converged to a solution such that all
C            residuals are at most TOLF in magnitude,
C            ABS(FNC(X,I)) .LE. TOLF.
C
C          3 Means that conditions for both IFLAG=1 and IFLAG=2 hold.
C
C          4 Means possible numerical convergence.  Behavior indicates
C            limiting precision calculations as a result of user asking
C            for too much accuracy or else convergence is very slow.
C            Residual norms and solution increment norms have
C            remained roughly constant over several consecutive
C            iterations.
C
C                         *** Task Interrupted ***
C
C          5 Means the allowable number of iterations has been met
C            without obtaining a solution to the specified accuracy.
C            Very slow convergence may be indicated.  Examine the
C            approximate solution returned and see if the error
C            tolerances seem appropriate.
C
C          6 Means the allowable number of iterations has been met and
C            the iterative process does not appear to be converging.
C            A local minimum may have been encountered or there may be
C            limiting precision difficulties.
C
C          7 Means that the iterative scheme appears to be diverging.
C            Residual norms and solution increment norms have
C            increased over several consecutive iterations.
C
C                         *** Task Cannot Be Continued ***
C
C          8 Means that a Jacobian-related matrix was singular.
C
C          9 Means improper input parameters.
C
C          *** IFLAG should be examined after each call to   ***
C          *** DSOS with the appropriate action being taken. ***
C
C
C     RW(1) -Contains a norm of the residual.
C
C     IW(3) -Contains the number of iterations used by the process.
C
C **********************************************************************
C
C***REFERENCES  K. M. Brown, Solution of simultaneous nonlinear
C                 equations, Algorithm 316, Communications of the
C                 A.C.M. 10, (1967), pp. 728-729.
C               K. M. Brown, A quadratically convergent Newton-like
C                 method based upon Gaussian elimination, SIAM Journal
C                 on Numerical Analysis 6, (1969), pp. 560-569.
C***ROUTINES CALLED  DSOSEQ, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Convert XERRWV calls to XERMSG calls, change Prologue
C           comments to agree with SOS.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DSOS
      INTEGER IFLAG, INPFLG, IPRINT, IW(*), K1, K2, K3, K4, K5, K6,
     1     LIW, LRW, MXIT, NC, NCJS, NEQ, NSRI, NSRRC
      DOUBLE PRECISION ATOLX, FNC, RTOLX, RW(*), TOLF, X(*)
      CHARACTER*8 XERN1
      CHARACTER*16 XERN3, XERN4
      EXTERNAL FNC
C***FIRST EXECUTABLE STATEMENT  DSOS
      INPFLG = IFLAG
C
C     CHECK FOR VALID INPUT
C
      IF (NEQ .LE. 0) THEN
         WRITE (XERN1, '(I8)') NEQ
         CALL XERMSG ('SLATEC', 'DSOS', 'THE NUMBER OF EQUATIONS ' //
     *      'MUST BE A POSITIVE INTEGER.  YOU HAVE CALLED THE ' //
     *      'CODE WITH NEQ = ' // XERN1, 1, 1)
         IFLAG = 9
      ENDIF
C
      IF (RTOLX .LT. 0.0D0 .OR. ATOLX .LT. 0.0D0) THEN
         WRITE (XERN3, '(1PE15.6)') ATOLX
         WRITE (XERN4, '(1PE15.6)') RTOLX
         CALL XERMSG ('SLATEC', 'DSOS', 'THE ERROR TOLERANCES FOR ' //
     *      'THE SOLUTION ITERATES CANNOT BE NEGATIVE. YOU HAVE ' //
     *      'CALLED THE CODE WITH  RTOLX = ' // XERN3 //
     *      ' AND ATOLX = ' // XERN4,2, 1)
            IFLAG = 9
      ENDIF
C
      IF (TOLF .LT. 0.0D0) THEN
         WRITE (XERN3, '(1PE15.6)') TOLF
         CALL XERMSG ('SLATEC', 'DSOS', 'THE RESIDUAL ERROR ' //
     *      'TOLERANCE MUST BE NON-NEGATIVE.  YOU HAVE CALLED THE ' //
     *      'CODE WITH TOLF = ' // XERN3, 3, 1)
            IFLAG = 9
      ENDIF
C
      IPRINT = 0
      MXIT = 50
      IF (INPFLG .EQ. (-1)) THEN
         IF (IW(1) .EQ. (-1)) IPRINT = -1
         MXIT = IW(2)
         IF (MXIT .LE. 0) THEN
            WRITE (XERN1, '(I8)') MXIT
            CALL XERMSG ('SLATEC', 'DSOS', 'YOU HAVE TOLD THE CODE ' //
     *         'TO USE OPTIONAL INPUT ITEMS BY SETTING IFLAG=-1. ' //
     *         'HOWEVER YOU HAVE CALLED THE CODE WITH THE MAXIMUM ' //
     *         'ALLOWABLE NUMBER OF ITERATIONS SET TO IW(2) = ' //
     *         XERN1, 4, 1)
            IFLAG = 9
         ENDIF
      ENDIF
C
      NC = (NEQ*(NEQ+1))/2
      IF (LRW .LT. 1 + 6*NEQ + NC) THEN
         WRITE (XERN1, '(I8)') LRW
         CALL XERMSG ('SLATEC', 'DSOS', 'DIMENSION OF THE RW ARRAY ' //
     *      'MUST BE AT LEAST 1 + 6*NEQ + NEQ*(NEQ+1)/2 .  YOU HAVE ' //
     *      'CALLED THE CODE WITH LRW = ' // XERN1, 5, 1)
         IFLAG = 9
      ENDIF
C
      IF (LIW .LT. 3 + NEQ) THEN
         WRITE (XERN1, '(I8)') LIW
         CALL XERMSG ('SLATEC', 'DSOS', 'DIMENSION OF THE IW ARRAY ' //
     *      'MUST BE AT LEAST 3 + NEQ.  YOU HAVE CALLED THE CODE ' //
     *      'WITH  LIW = ' // XERN1, 6, 1)
         IFLAG = 9
      ENDIF
C
      IF (IFLAG .NE. 9) THEN
         NCJS = 6
         NSRRC = 4
         NSRI = 5
C
         K1 = NC + 2
         K2 = K1 + NEQ
         K3 = K2 + NEQ
         K4 = K3 + NEQ
         K5 = K4 + NEQ
         K6 = K5 + NEQ
C
         CALL DSOSEQ(FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, MXIT, NCJS,
     1               NSRRC, NSRI, IPRINT, RW(1), RW(2), NC, RW(K1),
     2               RW(K2), RW(K3), RW(K4), RW(K5), RW(K6), IW(4))
C
         IW(3) = MXIT
      ENDIF
      RETURN
      END


      SUBROUTINE SETUP
*
*
*       Generation of initial coordinates & velocities.
*       -----------------------------------------------
*
      INCLUDE 'common6.h'
      PARAMETER (A0=1.0D0)
      REAL*8  RAN2,A(8)
*
*
*       Choose between uniform density and Plummer model.
      KDUM = IDUM1
      IF (KZ(5).GT.0) GO TO 20
*
*       Set up a uniform spherical system.
      DO 10 I = 1,N
    1     A(1) = 0.0D0
          DO 2 K = 1,3
              A(K+1) = 2.0*RAN2(KDUM) - 1.0
              A(1) = A(1) + A(K+1)**2
    2     CONTINUE
          IF (A(1).GT.1.0) GO TO 1
*
    4     A(5) = 0.0D0
          DO 5 K = 1,3
              A(K+5) = 2.0*RAN2(KDUM) - 1.0
              A(5) = A(5) + A(K+5)**2
    5     CONTINUE
          IF (A(5).GT.1.0) GO TO 4
*
          DO 8 K = 1,3
*             X(K,I) = A(1)*A(K+1)
*       Density proportional to 1/R**2.
              X(K,I) = A(K+1)
*       Constant density.
              XDOT(K,I) = A(K+5)
*       Isotropic velocities (magnitude randomized; no radial dependence).
    8     CONTINUE
   10 CONTINUE
*
      GO TO200
*
*       Initialize centre of mass terms.
   20 DO 25 K = 1,3
          CMR(K) = 0.0D0
          CMRDOT(K) = 0.0D0
   25 CONTINUE
*
*       Treat Plummer and lower options before Jaffe and Zhao models.
      IF (KZ(5).GE.5) GO TO 52
*
*       Generate initial conditions from Plummer model (A & A 37, 183).
      DO 40 I = 1,N
   30     A(1) = RAN2(KDUM)
          IF (A(1).LT.1.0D-10) GO TO 30
          RI = (A(1)**(-0.6666667) - 1.0)**(-0.5)
*       Reject distant particles.
          IF (RI.GT.10.0) GO TO 30
*
          A(2) = RAN2(KDUM)
          A(3) = RAN2(KDUM)
          X(3,I) = (1.0 - 2.0*A(2))*RI
          X(1,I) = SQRT(RI**2 - X(3,I)**2)*COS(TWOPI*A(3))
          X(2,I) = SQRT(RI**2 - X(3,I)**2)*SIN(TWOPI*A(3))
   32     A(4) = RAN2(KDUM)
          A(5) = RAN2(KDUM)
          A(6) = A(4)**2*(1.0 - A(4)**2)**3.5
          IF (0.1*A(5).GT.A(6)) GO TO 32
*
          A(8) = A(4)*SQRT(2.0)/(1.0 + RI**2)**0.25
          A(6) = RAN2(KDUM)
          A(7) = RAN2(KDUM)
          XDOT(3,I) = (1.0 - 2.0*A(6))*A(8)
          XDOT(1,I) = SQRT(A(8)**2 - XDOT(3,I)**2)*COS(TWOPI*A(7))
          XDOT(2,I) = SQRT(A(8)**2 - XDOT(3,I)**2)*SIN(TWOPI*A(7))
*
*       Accumulate c.m. terms.
          DO 35 K = 1,3
              CMR(K) = CMR(K) + BODY(I)*X(K,I)
              CMRDOT(K) = CMRDOT(K) + BODY(I)*XDOT(K,I)
   35     CONTINUE
   40 CONTINUE
*
*       Scale coordinates & velocities to analytical expectation values.
      SX = 1.5*TWOPI/16.0
      SV = SQRT(ZMASS/SX)
   42 DO 50 I = 1,N
          DO 45 K = 1,3
              X(K,I) = X(K,I) - CMR(K)/ZMASS
              XDOT(K,I) = XDOT(K,I) - CMRDOT(K)/ZMASS
              X(K,I) = SX*X(K,I)
              XDOT(K,I) = SV*XDOT(K,I)
   45     CONTINUE
          IF (KZ(22).EQ.1) THEN
              WRITE (10,48)  BODY(I), (X(K,I),K=1,3), (XDOT(K,I),K=1,3)
   48         FORMAT (1P,7E14.6)
          END IF
   50 CONTINUE
      IF (KZ(22).EQ.1) CALL FLUSH(10)
*
*       Terminate standard cases (#5 <=1) or Jaffee/BH (#5 >= 5 label 52).
      IF (KZ(5).LE.1.OR.KZ(5).GE.5) GO TO 200
*
*       Save membership of first system for colour plot (N2 = NZERO - N1).
   52 N1 = N
*       Check optional generation of two orbiting Plummer models.
      IF (KZ(5).EQ.2) THEN
          READ (5,*)  APO, ECC, N2, SCALE
          N2 = MIN(N,N2)
          SEMI = APO/(1.0 + ECC)
          SEMI = MIN(SEMI,50.0D0)
          SEMI = MAX(SEMI,2.0D0)
          ECC = MIN(ECC,0.999D0)
          ECC = MAX(ECC,0.0D0)
          ZM2 = 0.0
          KSKIP = N1/N2
          DO 54 I = 1,N2
              J = KSKIP*I
              ZM2 = ZM2 + BODY(J)
   54     CONTINUE
          FAC1 = ZM2/(ZMASS + ZM2)
          FAC2 = ZMASS/(ZMASS + ZM2)
*       Restrict volume ratio to 125 (i.e. unreasonable density contrast).
          IF (SCALE.LE.0.2D0) SCALE = 0.2
*       Increase total mass.
          ZMASS = ZMASS + ZM2
*       Set apocentre velocity for new combined mass.
          VAP = SQRT(ZMASS/SEMI)*SQRT((1.0 - ECC)/(1.0 + ECC))
          DO 55 I = 1,N
              IF (I.LE.N2) THEN
*       Copy members from first system by uniform skipping (N2 <= N1).
                  J = KSKIP*I
                  BODY(I+N) = BODY(J)
                  X(1,I+N) = SCALE*X(1,J) + FAC2*APO
                  X(2,I+N) = SCALE*X(2,J)
                  X(3,I+N) = SCALE*X(3,J)
                  XDOT(1,I+N) = XDOT(1,J)/SQRT(SCALE)
                  XDOT(2,I+N) = XDOT(2,J)/SQRT(SCALE) + FAC2*VAP
                  XDOT(3,I+N) = XDOT(3,J)/SQRT(SCALE)
              END IF
              X(1,I) = X(1,I) - FAC1*APO
              XDOT(2,I) = XDOT(2,I) - FAC1*VAP
   55     CONTINUE
      ELSE IF (KZ(5).EQ.3) THEN
*       Prepare case of accretion disk with massive perturber.
          READ (5,*)  APO, ECC, SCALE
          RIN = 0.5
          ROUT = 1.0
          ZMASS = 1.0
          BODY(1) = ZMASS
          DO 58 K = 1,3
              X(K,1) = 0.0
              XDOT(K,1) = 0.0
   58     CONTINUE
*       Generate a thin disk population in circular orbits.
          DO 60 I = 2,N
              BODY(I) = 1.0D-03/FLOAT(N)
              SEMI = RIN + (ROUT - RIN)*FLOAT(I)/FLOAT(N)
              VCIRC = SQRT((BODY(1) + BODY(I))/SEMI)
              PHASE = TWOPI*RAN2(KDUM)
              X(1,I) = SEMI*COS(PHASE)
              X(2,I) = SEMI*SIN(PHASE)
              X(3,I) = 0.01*(2.0*RAN2(KDUM) - 1.0)
              XDOT(1,I) = -VCIRC*SIN(PHASE)
              XDOT(2,I) = VCIRC*COS(PHASE)
              XDOT(3,I) = 0.01*VCIRC*(2.0*RAN2(KDUM) - 1.0)
   60     CONTINUE
*       Define membership of perturber and ensure no external tide.
          N2 = 1
          KZ(14) = 0
*       Redefine solar mass unit and astronomical length scale in AU.
          ZMBAR = 1.0
          RBAR = 1.0/2.05D+05
          BODY(N+1) = SCALE*BODY(1)
*       Set appropriate mass ratios for transforming to new c.m. frame.
          FAC1 = BODY(N+1)/(ZMASS + BODY(N+1))
          FAC2 = ZMASS/(ZMASS + BODY(N+1))
          ZMASS = ZMASS + BODY(N+1)
*       Form orbital elements for massive perturber (avoid large ECC.
          IF (ECC.LT.0.90) THEN
              SEMI = APO/(1.0 + ECC)
              PERI = SEMI*(1.0 - ECC)
          ELSE
              SEMI = APO
              PERI = 2.0*APO
          END IF
          VM2 = ZMASS*(2.0/PERI - 1.0/SEMI)
          VAP2 = ZMASS*(2.0/APO - 1.0/SEMI)
*       Determine initial y-velocity from angular momentum conservation.
          VY = SQRT(VM2)*PERI/APO
          VX = SQRT(VAP2 - VY**2)
*       Place perturber on the Y-axis with appropriate velocities.
          X(1,N+1) = APO*FAC2
          X(2,N+1) = 0.0
          X(3,N+1) = 0.0
          XDOT(1,N+1) = -VX*FAC2
          XDOT(2,N+1) = VY*FAC2
          XDOT(3,N+1) = 0.0
*       Displace the disk members and include negative y-velocity.
          DO 70 I = 1,N
              X(1,I) = X(1,I) - FAC1*APO
              XDOT(1,I) = XDOT(1,I) + FAC1*VX
              XDOT(2,I) = XDOT(2,I) - FAC1*VY
   70     CONTINUE
      ELSE IF (KZ(5).EQ.4) THEN
*       Include two massive bodies (ECC > 1: NAME = 1 & 2 free floating).
          N2 = 0
          READ (5,*)  SEMI, ECC, ZM1, ZM2
          WRITE (6,72)  SEMI, ECC, ZM1, ZM2
   72     FORMAT (/,12X,'MASSIVE BODIES    A =',1P,E9.1,
     &            '  E =',0P,F6.2,'  M1/<M> =',F6.2,'  M2/<M> =',F6.2)
          BODY(1) = ZM1
          BODY(2) = ZM2
          IF (ECC.LT.1.0) THEN
*       Set apocentre velocity for new combined mass (using NAME = 1 & 2).
              VAP = SQRT((ZM1 + ZM2)/SEMI)*SQRT((1.0 - ECC)/(1.0 + ECC))
              FAC1 = ZM2/(ZM1 + ZM2)
              FAC2 = ZM1/(ZM1 + ZM2)
              DO 75 K = 1,3
                  X(K,1) = 0.0
                  X(K,2) = 0.0
                  XDOT(K,2) = 0.0
   75         CONTINUE
*       Initialize binary with c.m. at rest (elements change in SCALE).
              X(1,1) = -FAC1*SEMI*(1.0 + ECC)
              X(1,2) = FAC2*SEMI*(1.0 + ECC)
              XDOT(2,1) = -FAC1*VAP
              XDOT(2,2) = FAC2*VAP
          END IF
      ELSE IF (KZ(5).EQ.5) THEN
*       Generate Jaffe model with length scale A0.
          ZMH = 1.0/SQRT(FLOAT(2*N))
          DO 100 I = 1,N
   80         ZM = RAN2(KDUM)
              RI = ZM*A0/(1.0 - ZM)
*       Reject distant particles.
              IF (RI.GT.10.0.OR.RI.LT.5.0D-03) GO TO 80
              A(2) = RAN2(KDUM)
              A(3) = RAN2(KDUM)
              X(3,I) = (1.0 - 2.0*A(2))*RI
              X(1,I) = SQRT(RI**2 - X(3,I)**2)*COS(TWOPI*A(3))
              X(2,I) = SQRT(RI**2 - X(3,I)**2)*SIN(TWOPI*A(3))
              VI2 = 1.0/(RI + A0) + 2.0*ZMH/RI
              DO 90 K = 1,3
                  VK2 = VI2*RAN2(KDUM)/3.0
                  ZZ = 2.0*RAN2(KDUM) - 1.0
                  SS = 1.0
                  IF (ZZ.LT.0.0) SS = -1.0
                  XDOT(K,I) = SS*SQRT(VK2)
   90         CONTINUE
*       Accumulate c.m. terms.
              DO 95 K = 1,3
                  CMR(K) = CMR(K) + BODY(I)*X(K,I)
                  CMRDOT(K) = CMRDOT(K) + BODY(I)*XDOT(K,I)
   95         CONTINUE
  100     CONTINUE
          SX = 1.0
          SV = 1.0
*       Use existing procedure for c.m. correction.
          GO TO 42
      ELSE IF (KZ(5).GE.6) THEN
*       Generate dwarf galaxy model with cusp & BH (Zhao, MN 278, 488).
          Y0 = 5.0*1.25/TWOPI/SQRT(FLOAT(N))
*       Calculate RH and ZMH by setting mass inside RH to 5*N^{1/2}*<M>.
          RH = (EXP(Y0) - 1.0D0)**0.4
          ZMH = 4.0*TWOPI/5.0*LOG(1.0D0 + RH**2.5)
*       Include possibility of using actual mass (read by SCALE).
          RCUT = 0.0
          IF (KZ(24).LT.0) THEN
              READ (5,*) ZMH, RCUT
              IF (ZMH.GT.0.0) THEN
                  Y0 = 1.25/TWOPI*(ZMH/FLOAT(N))
                  RH = (EXP(Y0) - 1.0D0)**0.4
              END IF
          END IF
*
*       Add experimental choice of favourite value.
          IF (KZ(28).EQ.3) THEN
              ZMH = 1.0/SQRT(FLOAT(2*N))
          ZMH = 5.0*ZMH
          ZMH = ZMH*ZMBAR*FLOAT(N)
      WRITE (6,605) ZMH, BODY(2)
  605 FORMAT (' KZ28!!!!    ZMH  BODY2 ',1P,2E10.2)
              Y0 = 1.25/TWOPI*(ZMH/FLOAT(N))
              RH = (EXP(Y0) - 1.0D0)**0.4
          END IF
*
*       Define BH mass inside radius of influence (unscaled units).
          REJECT = 100.0
          CUTM = 4.0*TWOPI/5.0*LOG(1.0D0 + REJECT**2.5)
*       Specify mass fraction using cut-off value and total in M_sun.
*         ZMH = ZMH/(FLOAT(N)*ZMBAR)*CUTM
          Y0 = 1.25/TWOPI*ZMH
          RH = (EXP(Y0) - 1.0D0)**0.4
          R2 = 100.0
          JDUM = -1
          RANJ = GASDEV(JDUM)
          IF (KZ(5).EQ.7) THEN
              RH = 0.006
              ZMH = LOG(1.0D0 + RH**0.75)
              REJECT = 200.0
              CUTM = LOG(1.0D0 + REJECT**0.75)
              R2 = 200.0
          END IF
*
          ICUT = 0
          DO 120 I = 1,N
  110         ZM = RAN2(KDUM)
              IF (KZ(5).EQ.6) THEN
                  ZX = 1.25/TWOPI*ZM
                  ZX = ZX*CUTM
                  ZY = EXP(ZX)
                  RI = (ZY - 1.0D0)**0.4
              ELSE
                  ZX = ZM*CUTM
                  ZY = EXP(ZX)
                  RI = (ZY - 1.0D0)**(4.0/3.0)
              END IF
*       Reject large and small distances before scaling.
              IF (RI.GT.REJECT.OR.RI.LT.1.0D-04) GO TO 110
              A(2) = RAN2(KDUM)
              A(3) = RAN2(KDUM)
              X(3,I) = (1.0 - 2.0*A(2))*RI
              X(1,I) = SQRT(RI**2 - X(3,I)**2)*COS(TWOPI*A(3))
              X(2,I) = SQRT(RI**2 - X(3,I)**2)*SIN(TWOPI*A(3))
  115         IF (KZ(5).EQ.6) THEN
                  CALL VDISP(RI,R2,ZMH,VI2)
              ELSE
                  CALL VDISP2(RI,R2,ZMH,VI2)
              END IF
              SIGMA = SQRT(VI2)
              VX = SIGMA*GASDEV(JDUM)
              VY = SIGMA*GASDEV(JDUM)
              VZ = SIGMA*GASDEV(JDUM)
              IF (MAX(ABS(VX),ABS(VY),ABS(VZ)).GT.3.0*SIGMA) GO TO 115
              XDOT(1,I) = VX
              XDOT(2,I) = VY
              XDOT(3,I) = VZ
              IF (RI.GT.RCUT) GO TO 120
              SEMI = 2.0/RI - (VX**2 + VY**2 + VZ**2)/ZMH
              SEMI = 1.0/SEMI
              RRDOT = X(1,I)*VX + X(2,I)*VY + X(3,I)*VZ
              ECC2 = (1.0 - RI/SEMI)**2 + RRDOT**2/(SEMI*ZMH)
              ECC = SQRT(ECC2)
              IF (SEMI*(1.0 - ECC).LT.0.5*RCUT) THEN
                  ICUT = ICUT + 1
                  GO TO 110
              END IF
  120     CONTINUE
*
          WRITE (6,125)  RH, ZMH, CUTM, RCUT, ICUT
  125     FORMAT (/,12X,'BLACK HOLE    RH =',F6.3,'  MBH =',F8.4,
     &                '  CUTM =',F7.3,'  RCUT =',F9.5,'  ICUT =',I5)
*
          SX = 1.0
          SV = 1.0
*       Substitute c.m. value (hardly matters with zero velocity).
          IF (KZ(24).LT.0) BODY(1) = ZMH
          IF (KZ(24).LT.-1) KSTAR(I) = 14
      WRITE (6,128)  BODY(1), BODY(2)
  128 FORMAT (' MASSES    b B12  ',1P,2E10.2)
          DO 130 K = 1,3
              X(K,1) = 0.0
              XDOT(K,1) = 0.0
              CMR(K) = 0.0
              CMRDOT(K) = 0.0
  130     CONTINUE
          DO 140 I = 1,N
              DO 135 K = 1,3
                  CMR(K) = CMR(K) + BODY(I)*X(K,I)
                  CMRDOT(K) = CMRDOT(K) + BODY(I)*XDOT(K,I)
  135         CONTINUE
  140     CONTINUE
          GO TO 42
      END IF
*
*       Specify new membership.
      N = N + N2
      NZERO = N
      NTOT = N
      IF (N.GE.NMAX-10) THEN
          WRITE (6,150)  N, NMAX
  150     FORMAT (' DANGER!    LIMIT EXCEEDED   N =',I6,'  NMAX =',I6)
          STOP
      END IF
*
      IF (KZ(5).EQ.2) THEN
          WRITE (6,155)  SEMI, ECC, N1, N2, SCALE
  155     FORMAT (/,12X,'PLUMMER BINARY    A =',F6.2,'  E =',F6.2,
     &                  '  N1 =',I6,'  N2 =',I6,'  SCALE =',F6.2)
      ELSE IF (KZ(5).EQ.3) THEN
          WRITE (6,160)  APO, ECC, PERI, SCALE
  160     FORMAT (/,12X,'MASSIVE PERTURBER    APO =',F6.2,'  E =',F6.2,
     &                  '  PERI =',F6.2,'  MP/M1 =',F6.2)
      END IF
*
*       Re-initialize centre of mass terms.
      DO 162 K = 1,3
          CMR(K) = 0.0D0
          CMRDOT(K) = 0.0D0
  162 CONTINUE
      ZMASS = 0.0
      DO 170 I = 1,N
          ZMASS = ZMASS + BODY(I)
          DO 165 K = 1,3
              CMR(K) = CMR(K) + BODY(I)*X(K,I)
              CMRDOT(K) = CMRDOT(K) + BODY(I)*XDOT(K,I)
  165     CONTINUE
  170 CONTINUE
      DO 180 I = 1,N
          DO 175 K = 1,3
              X(K,I) = X(K,I) - CMR(K)/ZMASS
              XDOT(K,I) = XDOT(K,I) - CMRDOT(K)/ZMASS
  175     CONTINUE
  180 CONTINUE
*
*       Save random number sequence in COMMON for future use.
  200 IDUM1 = KDUM
*
      RETURN
*
      END

      REAL*8 FUNCTION GASDEV(IDUM)
C
C          GAUSSIAN DISTRIBUTION (PRESS P. 203).
C          -------------------------------------
C
      COMMON/RANDG/  GSET,ISET
CC      DATA ISET/0/
      REAL*8 RAN2
      IF (ISET.EQ.0) THEN
1       V1=2.*RAN2(IDUM)-1.
        V2=2.*RAN2(IDUM)-1.
        R=V1**2+V2**2
        IF(R.GE.1.)GO TO 1
        FAC=SQRT(-2.*LOG(R)/R)
        GSET=V1*FAC
        GASDEV=V2*FAC
        ISET=1
      ELSE
        GASDEV=GSET
        ISET=0
      ENDIF
      RETURN
      END

      SUBROUTINE VDISP(RI,R2,ZMH,VI2)
*
*       Velocity dispersion of dwarf galaxy model.
*       ------------------------------------------
*
      IMPLICIT REAL*8 (A-H,O-Z)
*
*
      ONE3 = 1.0/3.0D0
      SUM = 0.0
      RHO = 1.0/(SQRT(RI)*(1.0 + RI**2*SQRT(RI)))
      NCALL = 1000 + 100.0/RI**2
      DR = 2.0*(R2 - RI)/FLOAT(NCALL)
      U = RI
*       Solve by Simpson's rule (NB! DR is twice the interval).
      DO 30 J = 1,NCALL
      U1 = U
      CALL VFUNC(ZMH,U1,F1)
      U2 = U + 0.5D0*DR
      CALL VFUNC(ZMH,U2,F2)
      U3 = U + DR
      CALL VFUNC(ZMH,U3,F3)
      SUM = SUM + ONE3*(F1 + 4.0D0*F2 + F3)*DR/2.0D0
      U = U + DR
      IF (U.LT.1.0) THEN
          DR = 1.4*DR
      END IF
      IF (U.GT.100.0) GO TO 40
   30 CONTINUE
*
   40 VI2 = SUM/RHO
*
      RETURN
      END

      SUBROUTINE VFUNC(ZMH,U,F)
      IMPLICIT REAL*8 (A-H,M,O-Z)
*
      U2 = U**2
      ZMU = 0.8*6.2831853*LOG(1.0D0 + U2*SQRT(U))
      RHO = 1.0/(SQRT(U)*(1.0 + U2*SQRT(U)))
      F = RHO*(ZMU + ZMH)/U2
*
      RETURN
      END

      SUBROUTINE VDISP2(RI,R2,ZMH,VI2)
*
*       Velocity dispersion of r^{-9/4} galaxy model.
*       ---------------------------------------------
*
      IMPLICIT REAL*8 (A-H,O-Z)
*
*
      ONE3 = 1.0/3.0D0
      SUM = 0.0
      RHO = 1.0/(RI**2.25*(1.0 + RI**0.75))
      NCALL = 1000 + 100.0/RI**2
      DR = 2.0*(R2 - RI)/FLOAT(NCALL)
      U = RI
*       Solve by Simpson's rule (NB! DR is twice the interval).
      DO 30 J = 1,NCALL
      U1 = U
      CALL VFUNC2(ZMH,U1,F1)
      U2 = U + 0.5D0*DR
      CALL VFUNC2(ZMH,U2,F2)
      U3 = U + DR
      CALL VFUNC2(ZMH,U3,F3)
      SUM = SUM + ONE3*(F1 + 4.0D0*F2 + F3)*DR/2.0D0
      U = U + DR
      IF (U.LT.1.0) THEN
          DR = 1.4*DR
      END IF
      IF (U.GT.200.0) GO TO 40
   30 CONTINUE
*
   40 VI2 = SUM/RHO
*
      RETURN
      END

      SUBROUTINE VFUNC2(ZMH,U,F)
      IMPLICIT REAL*8 (A-H,M,O-Z)
*
      U2 = U**2
      ZMU = LOG(1.0D0 + U**0.75)
      RHO = 1.0/(U**2.25*(1.0 + U**0.75))
      F = RHO*(ZMU + ZMH)/U2
*
      RETURN
      END


      SUBROUTINE INVERT(B,A)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!   Inverts a real 3 by 3 matrix
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      INTEGER, PARAMETER :: double = SELECTED_REAL_KIND(15,99)
      REAL(kind = double), DIMENSION(3,3) :: A, B
      REAL(kind = double) :: COM
      INTEGER :: I,J,K

      DO  I = 1,3
        DO  J = 1,3
          A(I,J) = B(I,J)
        END DO
      END DO

      DO K = 1,3
        COM = A(K,K)
        A(K,K) = 1.0D0
        DO J = 1,3
          A(K,J) = A(K,J)/COM
        END DO
        DO 5 I = 1,3
        IF((I-K) == 0) THEN
          GOTO 5
        END IF
        COM = A(I,K)
        A(I,K) = 0.0
        DO J = 1,3
          A(I,J) = A(I,J) - COM*A(K,J)
        END DO
    5   CONTINUE
      END DO

      END SUBROUTINE


      subroutine omekap(r,fom,fka)
      parameter (pi=3.1415926535)

      dimension rr(20000),om(20000),om2(20000),psi(20000),
     +                   ak(20000),ak2(20000)
      dimension psirr(20000)
      data ifirst /0/
      save ifirst, a, b
      save rr,om,om2,ak,ak2,nreq
c read omega, potential and potential'' from the frequencies file,
c spline-fit pot(r),
c and then use the 2nd derivatives of the potential in the table of
c kappa. these can then in turn be spline-fitted. should arrange for
c the boundary condition at r=0 to be even for pot, omega and kappa.
      if (ifirst.eq.0) then
	open(13,file='newfreqdbh.dat',status='old',err=999)
        read(13,*)
        read(13,*)
        read(13,*)
        nreq=0
c read only every other step, since remainder was linearly
c interpolated anyway
77      read(13,*,end=99) rr(nreq+2),vc,psi(nreq+2),psirr(nreq+2)
        om(nreq+2)=vc/rr(nreq+2)
        nreq=nreq+1
        read(13,*,end=99)
        goto 77
c extrapolate omega (linearly) and potential (quadratically) to zero
99      close(13)
        om(1)=2*om(2)-om(3)
        psi(1)=(4*psi(2)-psi(3))/3.
        psirr(1)=(4*psirr(2)-psirr(3))/3.
        rr(1)=0.
        call splined(rr,om,nreq,1.e32,1.e32,om2)
c        call splined(rr,psi,nreq,0.,1.e32,psi2)
c calculate epicycle frequencies
        ak(1)=2*om(1)
        do ir=2,nreq
          ak(ir)=sqrt(max(0.,psirr(ir)+3*om(ir)**2))
        enddo
        call splined(rr,ak,nreq,0.,1.e32,ak2)
c a and b are coefficients of potential -a/r -b/r^3 +c
c which give omeka and kappa as observed
c at the outer radius of the model---these are used to extrapolate if needed.
c in this potential om^2=a/r^3+3b/r^5, kap^2=a/r^3-3b/r^5
        a=rr(nreq)**3/2.*(om(nreq)**2+ak(nreq)**2)
        b=rr(nreq)**5/6.*(om(nreq)**2-ak(nreq)**2)
        c=a/rr(nreq)**3+b/rr(nreq)**5+psi(nreq)
!!!
        open(11,file='omekap.dat',status='unknown',err=23)
        do ir=1,nreq
          write(11,'(7g16.8)') rr(ir),om(ir),om2(ir),ak(ir),ak2(ir),
     +                          psi(ir),psirr(ir)
          enddo
        do ir=1,10
           rx=rr(nreq)*(1+0.1*ir)
           r3=a/rx**3
           r5=3*b/rx**5
           fom=sqrt(r3+r5)
           fka=sqrt(r3-r5)
           write(11,'(7g16.8)') rx,fom,0.,fka,0.,
     +                          c-(r3+r5/3.)*rx*rx,-2*r3-4*r5
           enddo
        close(11)
        write(0,*) 'wrote a table of frequencies in file omekap.dat.'
 23     continue
        ifirst=1
      endif

      if (r.gt.rr(nreq)) then
         r3=a/r**3
         r5=3*b/r**5
         fom=sqrt(r3+r5)
         fka=sqrt(r3-r5)
      else
         call splintd(rr,om,om2,nreq,r,fom)
         call splintd(rr,ak,ak2,nreq,r,fka)
         endif
!      do ir=1,nreq
!       print*,rr(ir),om(ir),ak(ir)
!      enddo
!      stop
      return
999   write(0,*) 'no file with frequencies corresponding to the potential!'
      stop
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!
!     this subroutine enables to calculate the basis incompressible
!     discharge coefficient
!
!     "Flow Characteristics of long orifices with rotation and corner radiusing"
!     W.F. Mcgreehan and M.J. Schotsch
!     ASME 87-GT-162
!
!     author: Yannick Muller
!
      subroutine cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu)
!
      implicit none
!
      real*8 cdu,bdh,reynolds,cd_re,rzdh,cd_r
!
      cd_re=0.5885d0+372d0/reynolds
!
!     the radius correction
!
      cd_r=1-(0.008d0+0.992d0*exp(-5.5d0*rzdh-3.5d0*rzdh**2))
     &     *(1-cd_re)
!
      cdu=1.d0-(1.d0-cd_r)*(1d0+1.3d0*exp(-1.606d0*(bdh*bdh)))
     &     *(0.435d0+0.021d0*bdh)
!
      return
!
      end


      SUBROUTINE four1(data,nn,isign)
      INTEGER isign,nn
      REAL data(2*nn)
      INTEGER i,istep,j,m,mmax,n
      REAL tempi,tempr
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      n=2*nn
      j=1
      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        goto 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=6.28318530717959d0/(isign*mmax)
        wpr=-2.d0*sin(0.5d0*theta)**2
        wpi=sin(theta)
        wr=1.d0
        wi=0.d0
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1)
            tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      goto 2
      endif
      return
      END