PROGRAM obsop_drifters
!===============================================================================
! PROGRAM: obsop_drifters
!
! USES:
!  use common
!  use params_model
!  use vars_model
!  use common_mom4
!  use params_obs
!  use vars_obs
!  use common_obs_mom4
!  use params_letkf
!  use letkf_drifters_local
!  use letkf_drifters_tools
!
!
! DESCRIPTION:
!   This program acts as the observation operator. It inputs observations (yo)
!   and a single forecast (xf) and computes the innovations (yo-H(xf))
!   associated with that member.
!
! USAGE:
! A separate instance is run independently for each member and timeslot
! All observations are typically preprocessed to the letkf obs format, then
! here they are read in and converted to the letkf obs2 format w/ H(x) data
! for each member added in a new column.
!
! !REVISION HISTORY:
!   08/15/2015 Luyu Sun modified for processing surface drifters
!   04/03/2014 Steve Penny modified for use with OCEAN at NCEP.
!   04/03/2013 Takemasa Miyoshi created for SPEEDY atmospheric model.
!
!-------------------------------------------------------------------------------
! $Author: Luyu Sun, Steve Penny, Takemasa Miyoshi $
!===============================================================================

  USE common ! use r_size
  USE common_obs_mom4 ! use get_nobs
  USE common_mom4
  USE letkf_drifters_local, ONLY : obs_local  !(DRIFTERS) NOTE: this is a slightly modified version of letkf_local.f90
  USE letkf_drifters_tools
  USE params_letkf
  USE params_model
  USE params_obs

  IMPLICIT NONE
  CHARACTER(slen) :: obsinfile = 'obsin_drifters.dat'	!IN (default) observation data of drifters
  CHARACTER(slen) :: guesfile = 'gues'	!IN data from model space in folder "DRIFTERS"
  CHARACTER(slen) :: obsoutfile = 'obsout_drifters.dat'	!OUT (default) datafile to be passed to letkf

  REAL(r_size), ALLOCATABLE :: elem(:)	!elem(:)
  REAL(r_size), ALLOCATABLE :: rlon(:)
  REAL(r_size), ALLOCATABLE :: rlat(:)
  REAL(r_size), ALLOCATABLE :: rlev(:)
  INTEGER     , ALLOCATABLE :: obid(:)	! odat
  REAL(r_size), ALLOCATABLE :: oerr(:)
  REAL(r_size), ALLOCATABLE :: ohx(:)	! Model forecast transformed to observation space: H(xb)
  INTEGER     , ALLOCATABLE :: oqc(:)	! quality control, necessary for drifters?
  REAL(r_size), ALLOCATABLE :: otime(:) ! time
  REAL(r_sngl), ALLOCATABLE :: v4d_all(:,:,:)
  !INTEGER :: nobs  ! total number of drifters observation
  REAL(r_size) :: ri, rj, rk
  INTEGER :: n, nnobs

  !-----------------------------------------------------------------------------
  ! Initialize the common_mom4 module, and process command line options
  !-----------------------------------------------------------------------------
  !CALL set_common_drifters
  !CALL process_command_line ! ??, what does this for should I write the subroutine

  !-----------------------------------------------------------------------------
  ! Read observations from file
  !-----------------------------------------------------------------------------
  CALL get_nobs(obsinfile,7,nnobs) !Later, need to add time.

  ALLOCATE(  elem(nnobs)  )
  ALLOCATE(  rlon(nnobs)  )
  ALLOCATE(  rlat(nnobs)  )
  ALLOCATE(  rlev(nnobs)  )
  ALLOCATE(  obid(nnobs)  ) ! odat
  ALLOCATE(  oerr(nnobs)  ) !
  ALLOCATE(   ohx(nnobs)  ) ! Model forecast transformed to observation space: H(xb)
  ALLOCATE(   oqc(nnobs)  )
  ALLOCATE(  otime(nnobs) ) ! otime
  print *, 'Finish get_nobs and start read_obs2_drifters.'
  CALL read_obs2_drifters(trim(obsinfile),nnobs,elem,rlon,rlat,rlev,obid,oerr,otime)
  print *, 'Start read_drifters'
  !-----------------------------------------------------------------------------
  ! Read model forecast for this member
  !-----------------------------------------------------------------------------
  CALL read_dimension(trim(guesfile),num_drifters,num_times)
  ALLOCATE(v4d_all(num_drifters,num_times,nv4d))
  CALL read_drifters(trim(guesfile),v4d_all) ! read_drifters is in letkf_drifters.f90, read data from model space.
  ! From this step, we obtain from models, num_drifters, num_times, drifter_ids, drifter_times.
  print *, 'Finish read_drifters'
  !-----------------------------------------------------------------------------
  ! Cycle through all observations
  !-----------------------------------------------------------------------------
  ohx=0.0d0
  DO n=1,nnobs
    !---------------------------------------------------------------------------
    ! Convert the physical coordinate to model grid coordinate (note: real, not integer)
    !---------------------------------------------------------------------------
    print *, 'Start drift2ijk'
    CALL drift2ijk(elem(n),obid(n),otime(n),rlon(n),rlat(n),rlev(n),ri,rj,rk)
    print *, 'Finish drift2ijk'
    ! ri: drifter id index
    ! rj: time idex for interpolation
    ! rk: var (x,y,x) index if elem == iv4d_x,y,z, then rk = 1,2,3 so on

    !---------------------------------------------------------------------------
    ! Filter in the tripolar region until localization is examined in the arctic !(ISSUE)
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Filter out observations that are out of range for the grid
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Check the observation against boundaries
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! observation operator (computes H(x)) for specified member
    !---------------------------------------------------------------------------
    CALL Trans_DtoY(elem(n),ri,rj,rk,v4d_all,ohx(n))

  enddo ! end do n=1,nobs

  !-----------------------------------------------------------------------------
  ! Print out the counts of observations removed for various reasons
  !-----------------------------------------------------------------------------

  !-----------------------------------------------------------------------------
  ! Write the observations and their associated innovations to file
  !-----------------------------------------------------------------------------
  CALL write_obs2_drifters(obsoutfile,nnobs,elem,rlon,rlat,rlev,obid,oerr,ohx,oqc,otime)

 CONTAINS
!SUBROUTINE process_command_line
!===============================================================================
! Process command line arguments
!===============================================================================
!END SUBROUTINE process_command_line
END PROGRAM obsop_drifters


        SUBROUTINE YRCCS4(CCS4,DET,FGWA,POLID,ALPHA,W1,COMBPX,
     *                    COEF,PEDGRE,DESCRP,ISTAT)
*
*  Module number:
*
*  Module name: YRCCS4
*
*  Keyphrase:
*  ----------
*       read polarimetry table ccs4
*
*  Description:
*  ------------
*       This routines reads the angle of each pass direction of the
*       Wollastan with respect to the Q = 1 coordinate axis of the
*       polarization reference frame.  It also reads the initial
*       waveplate position.
*
*  FORTRAN name: YRCCS4.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       CCS4                    I       table containing CCS4 coeffecients
*  Subroutines Called:
*  -------------------
*  CDBS
*       ymsput
*  SDAS:
*       uttopn, utpgti, utcfnd, utrgt*, uttclo
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       July 89  D. Lindler      Designed and coded
*	2	Mar 94	 H. Bushouse	 Mods to handle PEDIGREE keywords
*-------------------------------------------------------------------------------
*
* Input parameters
*
*       CCS4 - table name
*       DET  - detector name ('AMBER' or 'BLUE')
*       FGWA - disperser
*       POLID - polarizer id
*
* Output parameters
*       ALPHA - angles with respect to Q=1 coordinate axis
*       W1 - initial position of the waveplate
*       COMBPX - diode to compute wave. shift in two pass dir.
*       COEF - Interference coefficients
*	PEDGRE - CCS4 PEDIGREE keyword
*	DESCRP - CCS4 DESCRIP keyword
*       ISTAT - error status
*
*-----------------------------------------------------------------------------
        INTEGER ISTAT,COMBPX
        CHARACTER*64 CCS4
	CHARACTER*68 PEDGRE, DESCRP
        CHARACTER*5 DET
        CHARACTER*3 FGWA
        CHARACTER*1 POLID
        REAL ALPHA(2),W1
        DOUBLE PRECISION COEF(7)
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
C
C     UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C     THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET:
C
C                                       NUMBER OF ROWS WRITTEN TO
      INTEGER   TBNROW
      PARAMETER (TBNROW = 21)
C     END IRAF77.INC
C
C local variables
C
        INTEGER IDIN,COLIDS(14),ROW,NROWS
        CHARACTER*80 CONTXT
        CHARACTER*15 COLNAM(14)
        CHARACTER*5 DET1
        CHARACTER*3 FGWA1
        CHARACTER*1 POLID1
        LOGICAL NULL(14)
        DATA COLNAM/'DETECTOR','FGWA_ID','POLAR_ID','ALPHA1','ALPHA2',
     *              'W1','COMBPX','A','B','C1','C2','C3','C4','C5'/
C---------------------------------------------------------------------------
C
C Open table
C
        CALL UTTOPN(CCS4,RDONLY,IDIN,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR opening CCS4 table '//CCS4
                GO TO 998
        ENDIF
C
C get PEDIGREE and DESCRIP header keywords
C
        CALL UTHGTT(IDIN,'PEDIGREE',PEDGRE,ISTAT)
        CALL UTHGTT(IDIN,'DESCRIP',DESCRP,ISTAT)
C
C get number of rows
C
        CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR reading CCS4 table '//CCS4
                GO TO 999
        ENDIF
C
C Get column ids.
C
        CALL UTCFND(IDIN,COLNAM,14,COLIDS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR locating needed columns in CCS4 table '//
     *                  CCS4
                GO TO 999
        ENDIF
C
C Loop on rows
C
        DO 500 ROW=1,NROWS
C
C check detector
C
                CONTXT='ERROR reading CCS4 table '//CCS4
                CALL UTRGTT(IDIN,COLIDS(1),1,ROW,DET1,NULL,ISTAT)
                IF(ISTAT.NE.0)GO TO 999
                IF(DET1.NE.DET) GO TO 500
C
C Check grating
C
                CALL UTRGTT(IDIN,COLIDS(2),1,ROW,FGWA1,NULL,ISTAT)
                IF(ISTAT.NE.0)GO TO 999
                IF(FGWA1.NE.FGWA) GO TO 500
C
C Check polar-id
C
                CALL UTRGTT(IDIN,COLIDS(3),1,ROW,POLID1,NULL,ISTAT)
                IF(ISTAT.NE.0)GO TO 999
                IF(POLID1.NE.POLID) GO TO 500
C
C read values
C
                CALL UTRGTR(IDIN,COLIDS(4),2,ROW,ALPHA,NULL,ISTAT)
                IF(ISTAT.NE.0) GO TO 999
                CALL UTRGTR(IDIN,COLIDS(6),1,ROW,W1,NULL,ISTAT)
                IF(ISTAT.NE.0) GO TO 999
                CALL UTRGTI(IDIN,COLIDS(7),1,ROW,COMBPX,NULL,ISTAT)
                IF(ISTAT.NE.0) GO TO 999
                CALL UTRGTD(IDIN,COLIDS(8),7,ROW,COEF,NULL,ISTAT)
                IF(ISTAT.NE.0) GO TO 999
                CALL UTTCLO(IDIN,ISTAT)
                ISTAT=0
                GO TO 1000
500     CONTINUE
C
C If we made it here, no rows found
C
        WRITE(CONTXT,99)DET,FGWA,POLID
99      FORMAT('ERROR: No rows found in CCS4 for ',A5,1X,A3,
     *             ' polar_id= ',A1)
999     CALL UTTCLO(IDIN,ISTAT)
998     CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END


c "amp2" construye la atmosfera completa a partir de la antigua y
c de las perturbaciones multiplicativas nuevas (atmosfera reducida)
c 'atmos' es la atmosfera antigua completa a la salida es la atm. nueva
c 'pert'  es la atmosfera antigua reducida
c 'atmosr' es la atmosfera perturbada reducida
c a la salida atmos contendra la nueva atmosfera perturbada en todos los
c puntos, como una interpolacion por splines cubicos de la atmosfera
c perturbada en los nodos (reducida)
c
c    i variable   i  variable
c    -   tau1     -    tau2   profundidad optica a 5000 /AA
c    1   t1       9    t2     temperatura en ambos modelos (k)
c    2   p1      10    p2     presion electronica (dinas/cm**2)
c    3   mic1    11    mic2   microturbulencia (cm/s)
c    4   h1      12    h2     campo magnetico (G)
c    5   v1      13    v2     velocidad eje z (cm/s)
c    6   g1      14    g2     gamma (radianes)
c    7   f1      15    f2     fi (radianes)
c    8   mac1    16    mac2   macroturbulencia (en Km/s)
c    -   ff1     17    ff2    factor de llenado (ff1=1-ff2)
c                18    %      peso de la luz difusa
c trabajo siempre con el ff del segundo modelo
c m(i) es el numero de nodos de la varible i.
c Asi si m(i)=0 la variable i no se modifica
c     si m(i)=1 la variable i se modifica mediante un factor mult. cte.
c     si m(i)=2 la variable i se modifica mediante un factor mult. lineal
c     .........
c     si m(i)=-1 la variable i se modifica igual que la misma variable
c               de la otra atmosfera (es decir como i+/-8)
c En mdata(1-18) guardo los indices anteriores a la variable i (atm. ampliada)
c
c Basilio 22-3-93
c Basilio 23-3-93 (modificacion para contemplar el caso m(i)=-1)
c Basilio y Jose Carlos 9-1-95 (modificacion perturbaciones aditivas en fi)
c Basilio y Jose Carlos 6-2-95 (modificacion perturbaciones aditivas en gamma)
c
c _______________________________________________________________________

	subroutine amp2(ntau,m,atmos,atmosr)

	implicit real*4 (a-h,o-z)
	include 'PARAMETER'

	integer m(*),mdata(18)
	real*4 atmos(*),atmosr(*)
	real*4 x(kt),y(kt),yy(kt),pert(14*kt+4),f(kt,kt)
	real*4 tau(kt),t1(kt),p1(kt),tnew1(kt),pnew1(kt)
	real*4 t2(kt),p2(kt),tnew2(kt),pnew2(kt)
        real*4 pg1(kt),z1(kt),ro1(kt),b1(kt),gam1(kt)
        real*4 pg2(kt),z2(kt),ro2(kt),b2(kt),gam2(kt)
        character*29 var(18)
        character*100 control
        integer icalerr
        common/preciso/prec
        common/calerr/icalerr !si calculo errores=1 else =0
	common/canal/icanal
	common/nombrecontrol/control
        common/contornopg/ncontpg,pg01,pg02
        common/contornoro/ro01,ro02
        common/zetas/pg1,z1,ro1,pg2,z2,ro2
        common/pgmag/ipgmag

c	epsilon=1.d-2
	epsilon=1.e-8
	toffset=2500.
	pi=3.14159265

c precision equilibrio hidrostatico en tanto por uno (necesaria para equisubmu)
        prec=1.e-3  !

	call comprime2(ntau,m,atmos,pert) !atmosfera antigua reducida

        do i=1,16
	   mdata(i)=i*ntau+2*int(i/9)  ! indi. anteri. a la var. i (ampliada)
	end do
        mdata(17)=mdata(16)+1
        mdata(18)=mdata(17)+1

	do i=1,ntau
	   tau(i)=atmos(i)
           t1(i)=atmos(ntau+i)
	   p1(i)=atmos(2*ntau+i)	!inicializamos la presion
           t2(i)=atmos(9*ntau+2+i)
	   p2(i)=atmos(10*ntau+2+i)
	end do

	kred=0		!indice reducido
        kamp=ntau	!indice ampliado (los ntau puntos de tau1)
        cota=.5
	cotapres=.1
        cotafi=.395      !pi/8

	do i=1,18	!do en grupos de varibles (1=t,2=p,...etc)
           ntau2=ntau
           if(i.eq.8.or.i.eq.16.or.i.eq.17.or.i.eq.18)ntau2=1!mac1,mac2,ff2,%

           if(m(i).eq.1)then	            !si pert. constante sumo
              kred=kred+1
              if(i.eq.6.or.i.eq.14)then
                 y1=atmosr(kred)-pert(kred)
		 if(y1.lt.0. .and. atmosr(kred). lt.0)then
		    y1=-pert(kred)/2.
		 endif
		 if(atmosr(kred). gt. pi)then
		   y1=(pi-pert(kred))/2.
		 endif
		 if(y1.lt.-cotafi)y1=-cotafi   !acoto inferiormente
	         if(y1.gt.cotafi)y1=cotafi     !acoto superiormente
	      else if(i.eq.7.or.i.eq.15.)then
                 y1=atmosr(kred)-pert(kred)
  	         if(y1.lt.-cotafi)y1=-cotafi   !acoto inferiormente
	         if(y1.gt.cotafi)y1=cotafi     !acoto superiorment
	      else if (i.eq.2.or.i.eq.10) then
	         if(pert(kred).eq.0)goto 999
	         y1=(atmosr(kred)/pert(kred))-1.    !perturbacion multiplicativa
c  	         if(y1.lt.-cota)y1=-cota   !acoto inferiormente
c	         if(y1.gt.cota)y1=cota     !acoto superiormente
c	         if(i .eq.2.)print*,'amp2 125 multiplicativa',y1
	         y1=y1*pert(kred) 	            !perturbaciona aditiva
c	         if(i .eq.2.)print*,'amp2 127 indoce - reducida- aditiva',kred,pert(kred),y1
      	      else
                 if(pert(kred).eq.0)goto 999
	         y1=(atmosr(kred)/pert(kred))-1.    !perturbacion multiplicativa
  	         if(y1.lt.-cota)y1=-cota   !acoto inferiormente
	         if(y1.gt.cota)y1=cota     !acoto superiormente
	         y1=y1*pert(kred) 	            !perturbaciona aditiva
              end if

              if(i.eq.17)then        !si es el f.f
                 varfill=(1./atmos(kamp+1))-1.
                 varfill=varfill+y1
	         atmos(kamp+1)=1./(1.+ varfill)
              else if(i.eq.18)then        !si es el %
                 varpercen=atmos(kamp+1)/(100.-atmos(kamp+1))
                 varpercen=varpercen+y1
	         atmos(kamp+1)=100.*varpercen/(1.+ varpercen)
	      else if(i.eq.2 .or. i.eq.10)then
	         pmin=1.e15
	         do j=1,ntau2
	            if(atmos(kamp+j) .lt. pmin)pmin=atmos(kamp+j)
	         end do
	         if(y1+pmin .lt. 0.05*pmin)y1=-0.95*pmin
	         do j=1,ntau2
	            presionelec=atmos(kamp+j)+y1
                    if(presionelec .lt. 1.e-6)presionelec=1.e-6
                    atmos(kamp+j)=presionelec
                 end do
	      else   !if(i.ne.5.and.i.ne.13)then    !para una cte en velocidad
                 do j=1,ntau2
                    atmos(kamp+j)=atmos(kamp+j)+y1
                 end do
              end if

           else if(m(i).gt.1)then

              mm=(ntau-1)/(m(i)-1)   !espaciado entre nodos
              kred1=kred+m(i)           !indice del ultimo nodo de cada variable
              do j=1,m(i)
                 kred=kred+1
                 jj=(j-1)*mm+1	               !indice de tau en los nodos
              	 x(j)=atmos(jj)	               !tau en los nodos
                 if(i.eq.7.or.i.eq.15)then
                    y(j)=atmosr(kred)-pert(kred)
  	            if(y(j).lt.-cotafi)y(j)=-cotafi   !acoto inferiormente
	            if(y(j).gt.cotafi)y(j)=cotafi     !acoto superiormente
		 else if(i.eq.6.or.i.eq.14)then
                    y1=atmosr(kred)-pert(kred)
		    if(y1.lt.0. .and. atmosr(kred). lt.0)then
		       y1=-pert(kred)/2.
		    endif
		    if(atmosr(kred). gt. pi)then
		       y1=(pi-pert(kred))/2.
		    endif
  	            if(y1.lt.-cotafi)y1=-cotafi   !acoto inferiormente
	            if(y1.gt.cotafi)y1=cotafi     !acoto superiormente
		    y(j)=y1
		 else if (i.eq.2.or.i.eq.10) then
		    y1=(atmosr(kred)/pert(kred1))-1.  !pert. multiplicativa
c                    y1=atmosr(kred)-pert(kred)        !perturbaciona aditiva en la presion e
 	            if(y1.lt.-cotapres)y1=-cotapres   !acoto inferiormente
	            if(y1.gt.cotapres)y1=cotapres     !acoto superiormente
                    y(j)=y1*pert(kred1)               !escala con la presion en el ultimo no
c                    print*,'amp2 171 =',j,y(j)
c                    y(j)=y1*pert(kred)     !perturb. aditiva en los nodos
c                    print*,'amp2 178 ',pert(kred),y1,y(j)
      	         else
	            y1=(atmosr(kred)/pert(kred))-1.  !pert. multiplicativa
	            if(y1.lt.-5.d-1)y1=-5.d-1 !acoto inferiormente
	            if(y1.gt.1.5d+0)y1=1.5d0  !acoto superiormente
	            y(j)=y1*pert(kred)     !perturb. aditiva en los nodos
                 end if
	      end do

	      if(ntau2.ne.ntau)then
		  print*,'STOP: Are there more than one parameter for the macroturbulence or filling factor?'
	          stop
              end if

	      call splines22(x,y,m(i)-2,ntau,tau,yy,f)

              if(i.eq.2.or.i.eq.10)then
                 do j=1,ntau2
                    presionelec=atmos(kamp+j)+yy(j)
c                    print*,'amp2 203 atmos(kamp+j) yy presionelec',j,atmos(kamp+j),yy(j),presionelec
c                   if(presionelec .lt. atmos(kamp+j)*.25)print*,'amp2 204 atmos(kamp+j) yy presionelec',atmos(kamp+j),yy(j),presionelec
                    if(presionelec .lt. atmos(kamp+j)*.1)presionelec=.1*atmos(kamp+j)
                    if(presionelec .lt. 1.e-6)presionelec=1.e-6
c                    print*,'amp2 207 ',i,kamp+j,3*ntau,presionelec
                    atmos(kamp+j)=presionelec
                 end do
	      else
                 do j=1,ntau2
                    atmos(kamp+j)=atmos(kamp+j)+yy(j)
                 end do
              end if
	   end if
	   kamp=kamp+ntau2
	   if(i.eq.8)kamp=kamp+ntau+1	!los ntau puntos de tau2 y el de ff1
	end do
c	print*,'pe amp2 ',3*ntau,atmos(3*ntau)

c en caso de que no se corrija la presion
c ponemos las presiones en equilibrio hidrostatico con las temperaturas
	vart1=0.0
	vart2=0.0
        do i=1,ntau
           tnew1(i)=atmos(ntau+i)
           tnew2(i)=atmos(9*ntau+2+i)
	   avar1=abs((tnew1(i)-t1(i))/t1(i))
	   avar2=abs((tnew2(i)-t2(i))/t2(i))
	   vart1=amax1(vart1,avar1)           !maxima variacion de t1
	   vart2=amax1(vart2,avar2)           !maxima variacion de t2
	end do

	varp1=0.0
	varp2=0.0
        do i=1,ntau
           pnew1(i)=atmos(2*ntau+i)
           pnew2(i)=atmos(10*ntau+2+i)
           b1(i)=atmos(4*ntau+i)
           b2(i)=atmos(12*ntau+2+i)
           gam1(i)=atmos(6*ntau+i)
           gam2(i)=atmos(14*ntau+2+i)
	   pavar1=abs((pnew1(i)-p1(i))/p1(i))
	   pavar2=abs((pnew2(i)-p2(i))/p2(i))
	   varp1=amax1(varp1,pavar1)           !maxima variacion de p1
	   varp2=amax1(varp2,pavar2)           !maxima variacion de p2
	end do

c suavizo la variacion de la temperatura si es muy fuerte (mayor del 40%)
c	if(vart1.gt.0.50)then                !si la max. var. de t1
c           do i=1,ntau
c              tnew1(i)=(tnew1(i)+2.*t1(i))/3.
c	   end do
c        end if
c	if(vart2.gt.0.50)then                !si la max. var. de t2
c           do i=1,ntau
c              tnew2(i)=(tnew2(i)+2.*t2(i))/3.
c	   end do
c        end if

	do i=1,ntau  !no dejamos que la temperatura baje de toffset
	      if(tnew1(i).lt.toffset)tnew1(i)=toffset
	      if(tnew2(i).lt.toffset)tnew2(i)=toffset
	enddo

c no dejamos que b sea negativo ni gamma
        do i=1,ntau
	    if( m(4).gt.0 .and. atmos(i+4*ntau).le.0.)atmos(i+4*ntau)=1.
	    if(m(12).gt.0 .and. atmos(i+12*ntau+2).le.0.)atmos(i+12*ntau+2)=1.
	end do

c suavizo la variacion de la presion si es muy fuerte (mayor del 40%)
c	if(varp1.gt.0.40 .and. m(2).eq.0 )then                !si la max. var. de p1
c           do i=1,ntau
c              dif=pnew1(i)-p1(i)
c              esc=1.2
c              if(dif .lt. 0.)esc=.8
c              atmos(2*ntau+i)=esc*p1(i)
c	   end do
c        end if
c	if(varp2.gt.0.40 .and. m(10).eq.0)then                !si la max. var. de p2
c           do i=1,ntau
c              dif=pnew2(i)-p2(i)
c              esc=1.2
c              if(dif .lt. 0.)esc=.8
c              atmos(10*ntau+2+i)=esc*p2(i)
c	   end do
c        end if

c coloco la p1 en equilibrio hidrostatico si t1 cambio mas de .002% (epsilon)
c y no estoy evaluando errores
	   if(m(2).eq.0) then
	        if(ncontpg.eq.0)call equisubmu(ntau,tau,tnew1,p1,pg1,z1,ro1)
                if(ncontpg.eq.-1)then
                   ro1(ntau)=ro01
                   call pgpefromrho(tnew1(ntau),ro1(ntau),p1(ntau),pg1(ntau))
                   pg01=pg1(ntau)
                endif
	        if(ncontpg.ne.0)then
                   if(ipgmag.ne.1)call
     & equisubmu_cont(ntau,tau,tnew1,p1,pg01,pg1,z1,ro1)
                   if(ipgmag.eq.1)call
     & equisubmu_contmag(ntau,tau,tnew1,p1,pg01,pg1,z1,ro1,b1,gam1)
                end if
	        do i=1,ntau
                   atmos(ntau+i)=tnew1(i)
                   atmos(2*ntau+i)=p1(i)
	        end do
	     else
	        do i=1,ntau
                   atmos(ntau+i)=tnew1(i)
                   p1(i)= atmos(2*ntau+i)
                end do
                call pgzrofrompetau(ntau,tau,tnew1,p1,pg1,z1,ro1)
	     end if

        if(m(9).ne.0.or.m(10).ne.0.or.m(12).ne.0.or.m(14).ne.0)then
	     if(m(10).eq.0) then
	        if(ncontpg.eq.0)call equisubmu(ntau,tau,tnew2,p2,pg2,z2,ro2)
                if(ncontpg.eq.-1)then
                   ro2(ntau)=ro02
                   call pgpefromrho(tnew2(ntau),ro2(ntau),p2(ntau),pg2(ntau))
                   pg02=pg2(ntau)
                endif
	        if(ncontpg.ne.0)then
                   if(ipgmag.ne.1)call
     & equisubmu_cont(ntau,tau,tnew2,p2,pg02,pg2,z2,ro2)
                   if(ipgmag.eq.1)call
     & equisubmu_contmag(ntau,tau,tnew2,p2,pg02,pg2,z2,ro2,b2,gam2)
                end if
                do i=1,ntau
                   atmos(9*ntau+2+i)=tnew2(i)
                   atmos(10*ntau+2+i)=p2(i)
	        end do
	     else
                do i=1,ntau
                   atmos(9*ntau+2+i)=tnew2(i)
                   p2(i)= atmos(10*ntau+2+i)
	        end do
	        call pgzrofrompetau(ntau,tau,tnew2,p2,pg2,z2,ro2)
	     end if
	end if

c Si m(i)=-1 se toma la variable de la otra atmosfera
	do i=1,16   !el ff2 no puede tener -1 (en ese caso se toma como 0)
           ntau2=ntau
           if(i.eq.8.or.i.eq.16)ntau2=1 !si mac1,mac2 o ff2
           if(m(i).eq.-1)then
              ii=i-8
              if(ii.le.0)ii=i+8
              do j=1,ntau2
		 atmos(mdata(i)+j)=atmos(mdata(ii)+j)
              end do
           end if
        end do

c en cualquier caso los ff tienen que ser complementarios
        atmos(8*ntau+2)=1.-atmos(16*ntau+4)

	return

999	var(1)='temperature (model 1)      '
        var(2)='electronic pressure (model 1)'
        var(3)='microturbulence (model 1)    '
        var(4)='magnetic field (model 1)     '
        var(5)='LOS velocity (model 1)       '
        var(6)='incl. magn. field  (model 1) '
        var(7)='azimuth magn. field (model 1)'
        var(8)='macroturbulence (model 1)    '
	var(9)='temperature (model 2)        '
        var(10)='electronic pressure (model 2)'
        var(11)='microturbulence (model 2)    '
        var(12)='magnetic field (model 2)     '
        var(13)='LOS velocity (model 2)       '
        var(14)='incl. magn. field  (model 2) '
        var(15)='azimuth magn. field (model 2)'
        var(16)='macroturbulence (model 2)    '
        var(17)='filling factor (model 2)     '
        var(18)='stray light factor           '

	print*,' '
	write(*,'(a10,a30,a18)') 'STOP: The ',var(i),'is zero somewhere.'
        print*,'     Since RELATIVE perturbations are used in the inversion,'
        print*,'     non zero initial values for that parameter have to be provided.'
c	open(icanal,file=control,fileopt='eof')
c	write(icanal,*) ' '
c	write(icanal,'(a10,a30,a18)') 'STOP: The ', var(i),'is zero somewhere.'
c        write(icanal,*) '     Since RELATIVE perturbations are used in the inversion,'
c        write(icanal,*) '     non zero initial values for that parameter have to be provided.'
c	close(icanal)
        print*,' '
	print*,'__________________________________________________________________________________'
	stop

	end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine lm_function: calculate Levenberg-Marquardt fitness
!     for a DG-EVB calculation
!

subroutine lm_function(m_ind,n_ind,x_var,fvec,iflag)
use evb_mod
use lm_module
implicit none
integer::m_ind,n_ind
integer::slope_sign,sign_old ! for wiggle scoring
real(kind=8)::fvec(m_ind),fun
real(kind=8)::dg_old  ! for wiggle scoring
real(kind=8)::dg_func,E1,E2,V12,deltaE,root
integer::i,iflag
real(kind=8)::x_var(n_ind),xdat(m_ind),ydat(m_ind)
!
!     the alpha values are now stored into the x(:) array
!     n=number of alphas, m=number of path points
!
call build_dmat(dg_evb_mode_lm,mat_size_lm,x_var)
call mat_diag(mat_size_lm)
extrema=0  ! number of EVB energy maxima/minima along the path
do i=1,m_ind
   V12=0
   E1=ff_e1_lm(i)
   E2=ff_e2_lm(i)
   deltaE=abs(E1-E2)
   call sum_v12(dg_evb_mode_lm,mat_size_lm,x_var,path_int_lm(:,i),V12)
   root=(0.5d0*(E1-E2))*(0.5d0*(E1-E2))+V12
   if (root .le. 0) then
      dg_func=0.5*(E1+E2)
   else
      dg_func=0.5*(E1+E2)-sqrt(root)
   end if
!
!     To avoid many artifical wiggles, score them and apply penalty
!
!   if (i .gt. 1) then
!      if (dg_func-dg_old .lt. 0d0) then
!     positive slope
!         slope_sign=+1
!      else
!     negative slope
!         slope_sign=-1
!      end if
!
!     increment the number of extrema if the slope has changed
!
!      if (slope_sign .ne. sign_old) then
!         extrema=extrema+1
!      end if
!   end if
!   sign_old=slope_sign
!   dg_old=dg_func
   fvec(i)=(dg_func-energies_ref_lm(i))*(dg_func-energies_ref_lm(i))
!
!     if more than three extrema (maxima and TS) are present, apply
!     the penalty; the higher the more extrema are present!
!
!   if (extrema .gt. 3) then
!       write(*,*) extrema
!      f_vec=f_vec+0.001d0*(extrema-3)
!   end if
end do

return
end subroutine lm_function


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYUPEV
C...Administers the hard-process generation required for output to the
C...Les Houches event record.

      SUBROUTINE PYUPEV

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYCOMP

C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pyctag'
      include 'inc/pydat1'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint4'

C...HEPEUP for output.
      include 'inc/hepeup'

C...Stop if no subprocesses on.
      IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
        WRITE(MSTU(11),5100)
        STOP
      ENDIF

C...Special flags for hard-process generation only.
      MSTP71=MSTP(71)
      MSTP(71)=0
      MST128=MSTP(128)
      MSTP(128)=1

C...Initial values for some counters.
      N=0
      MINT(5)=MINT(5)+1
      MINT(7)=0
      MINT(8)=0
      MINT(30)=0
      MINT(83)=0
      MINT(84)=MSTP(126)
      MSTU(24)=0
      MSTU70=0
C unvar       MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
      MINT(33)=0

C...If variable energies: redo incoming kinematics and cross-section.
      MSTI(61)=0
      IF(MSTP(171).EQ.1) THEN
        CALL PYINKI(1)
        IF(MSTI(61).EQ.1) THEN
          MINT(5)=MINT(5)-1
          RETURN
        ENDIF
        IF(MINT(121).GT.1) CALL PYSAVE(3,1)
        CALL PYXTOT
      ENDIF

C...Do not allow pileup events.
      MINT(82)=1

C...Generate variables of hard scattering.
      MINT(51)=0
      MSTI(52)=0
  100 CONTINUE
      IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
      MINT(31)=0
      MINT(51)=0
      MINT(57)=0
      CALL PYRAND
      IF(MSTI(61).EQ.1) THEN
        MINT(5)=MINT(5)-1
        RETURN
      ENDIF
      IF(MINT(51).EQ.2) RETURN
      ISUB=MINT(1)

      IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
C...Hard scattering (including low-pT):
C...reconstruct kinematics and colour flow of hard scattering.
        MINT31=MINT(31)
        MINT(31)=MINT31
        MINT(51)=0
        CALL PYSCAT
        IF(MINT(51).EQ.1) GOTO 100
C unvar IPU1=MINT(84)+1
C unvar IPU2=MINT(84)+2

C...Decay of final state resonances.
        MINT(32)=0
        IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
     &  CALL PYRESD(0)
        IF(MINT(51).EQ.1) GOTO 100
        MINT(52)=N

C...Longitudinal boost of hard scattering.
        BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
        CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)

      ELSEIF(ISUB.NE.99) THEN
C...Diffractive and elastic scattering.
        CALL PYDIFF

      ELSE
C...DIS scattering (photon flux external).
        CALL PYDISG
        IF(MINT(51).EQ.1) GOTO 100
      ENDIF

C...Check that no odd resonance left undecayed.
      MINT(54)=N
      NFIX=N
      DO 120 I=MINT(84)+1,NFIX
        IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
     &  K(I,2).NE.22) THEN
          KCA=PYCOMP(K(I,2))
          IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
            CALL PYRESD(I)
            IF(MINT(51).EQ.1) GOTO 100
          ENDIF
        ENDIF
  120 CONTINUE

C...Boost hadronic subsystem to overall rest frame.
C..(Only relevant when photon inside lepton beam.)
      IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)

C...Store event information and calculate Monte Carlo estimates of
C...subprocess cross-sections.
      CALL PYDOCU

C...Transform to the desired coordinate frame.
      CALL PYFRAM(MSTP(124))
      MSTU(70)=MSTU70
      PARU(21)=VINT(1)

C...Restore special flags for hard-process generation only.
      MSTP(71)=MSTP71
      MSTP(128)=MST128

C...Trace colour tags; convert to LHA style labels.
      NCT=100
      DO 150 I=MINT(84)+1,N
        MCT(I,1)=0
        MCT(I,2)=0
  150 CONTINUE
      DO 160 I=MINT(84)+1,N
        KQ=KCHG(PYCOMP(K(I,2)),2)*SIGN(1,K(I,2))
        IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
          IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
     &    THEN
            IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
            IDA=MOD(K(I,4),MSTU(5))
            IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,2).NE.0) THEN
              MCT(I,1)=MCT(IMO,2)
            ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,1).NE.0) THEN
              MCT(I,1)=MCT(IMO,1)
            ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
     &      MCT(IDA,2).NE.0) THEN
              MCT(I,1)=MCT(IDA,2)
            ELSE
              NCT=NCT+1
              MCT(I,1)=NCT
            ENDIF
          ENDIF
          IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
     &    THEN
            IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
            IDA=MOD(K(I,5),MSTU(5))
            IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,1).NE.0) THEN
              MCT(I,2)=MCT(IMO,1)
            ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,2).NE.0) THEN
              MCT(I,2)=MCT(IMO,2)
            ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
     &      MCT(IDA,1).NE.0) THEN
              MCT(I,2)=MCT(IDA,1)
            ELSE
              NCT=NCT+1
              MCT(I,2)=NCT
            ENDIF
          ENDIF
        ENDIF
  160 CONTINUE

C...Put event in HEPEUP commonblock.
      NUP=N-MINT(84)
      IDPRUP=MINT(1)
      XWGTUP=1D0
      SCALUP=VINT(53)
      AQEDUP=VINT(57)
      AQCDUP=VINT(58)
      DO 180 I=1,NUP
        IDUP(I)=K(I+MINT(84),2)
        IF(I.LE.2) THEN
          ISTUP(I)=-1
          MOTHUP(1,I)=0
          MOTHUP(2,I)=0
        ELSEIF(K(I+4,3).EQ.0) THEN
          ISTUP(I)=1
          MOTHUP(1,I)=1
          MOTHUP(2,I)=2
        ELSE
          ISTUP(I)=1
          MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
          MOTHUP(2,I)=0
        ENDIF
        IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
     &  ISTUP(K(I+MINT(84),3)-MINT(84))=2
        ICOLUP(1,I)=MCT(I+MINT(84),1)
        ICOLUP(2,I)=MCT(I+MINT(84),2)
        DO 170 J=1,5
          PUP(J,I)=P(I+MINT(84),J)
  170   CONTINUE
        VTIMUP(I)=V(I,5)
        SPINUP(I)=9D0
  180 CONTINUE

C...Optionally write out event to disk. Minimal size for time/spin fields.
      IF(MSTP(162).GT.0) THEN
        WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
        DO 190 I=1,NUP
          IF(VTIMUP(I).EQ.0D0) THEN
            WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
     &      MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
     &      ' 0. 9.'
          ELSE
            WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
     &      MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
     &      VTIMUP(I),' 9.'
          ENDIF
  190   CONTINUE

C...Optional extra line with parton-density information.
        IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
     &  PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
      ENDIF

C...Error messages and other print formats.
 5100 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')
 5200 FORMAT(1P,2I6,4E14.6)
 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)

      RETURN
      END


! This file is part of DASH.
! SPDX-Identifier: MIT
!
! Copyright 2002 Cambridge Crystallographic Data Centre
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
!*****************************************************************************
!
      MODULE RRVAR

      IMPLICIT NONE

      INTEGER     RR_MVAR
      PARAMETER ( RR_MVAR = 300 )

      INTEGER     RR_maxatm
      PARAMETER ( RR_maxatm = 300 )

      INTEGER     RR_maxfrg
      PARAMETER ( RR_maxfrg = 32 )

! RR_maxfrg = Maximum number of fragments = individual Z-matrices
! At the moment the maximum number of fragments is limited by the interface

      INTEGER RR_iopttran(1:3, 1:RR_maxfrg)
      INTEGER RR_ioptrot(1:4, 1:RR_maxfrg)
      INTEGER RR_ioptb(1:RR_maxatm, 1:RR_maxfrg)
      INTEGER RR_iopta(1:RR_maxatm, 1:RR_maxfrg)
      INTEGER RR_ioptt(1:RR_maxatm, 1:RR_maxfrg)
      INTEGER RR_ioptITF
      INTEGER RR_ioptPO

! ioptb  = optimise bond length 1=YES, 0=NO.
! iopta  = optimise valence angle 1=YES, 0=NO.
! ioptt  = optimise torsion angle 1=YES, 0=NO.

      LOGICAL RR_Show_bond(1:RR_maxatm,1:RR_maxfrg)
      LOGICAL RR_Show_angle(1:RR_maxatm,1:RR_maxfrg)
      LOGICAL RR_Show_torsion(1:RR_maxatm,1:RR_maxfrg)

! Optimising torsions/angles/bonds with Hydrogens in them does not make much sense,
! so these parameters can be hidden from the Rietveld refinement dialogue.

      REAL RR_tran(1:3, 1:RR_maxfrg)
      REAL RR_rot(1:4, 1:RR_maxfrg)
      REAL RR_blen(1:RR_maxatm, 1:RR_maxfrg)
      REAL RR_alph(1:RR_maxatm, 1:RR_maxfrg)
      REAL RR_bet(1:RR_maxatm, 1:RR_maxfrg)
      REAL RR_ITF ! Global Isotropic Temperature Factor
      REAL RR_PO ! Extent of Preferred Orientation

! tran   = translation
! blen   = bond length     (wrt iz1)
! alph   = valence angle   (wrt iz1 & iz2)
! bet    = torsion angle   (wrt iz1, iz2 & iz3)

      REAL RR_Params(1:RR_MVAR)
      REAL RR_InitSteps(1:RR_MVAR) ! Initial step sizes for Simplex
      INTEGER RR_var2ITF

      INTEGER RR_npar

! RR_nvar = RR_npar for Rietveld refinement

      REAL RR_XATO_Orig(1:3,1:RR_maxatm)

! The original atomic co-ordinates before Rietveld refinement, for comparison.

      END MODULE RRVAR
!
!*****************************************************************************
!


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  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, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine s12tim ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )

!>\file
!>       Generic module to process resuspension, burial, digging S1 & S2

      implicit none

      real     pmsa  ( * ) , fl    (*)
      integer  ipoint(34) , increm(34) , noseg , noflux,
     +         iexpnt(4,*) , iknmrk(*) , noq1, noq2, noq3, noq4

      integer  ip(34), iflux, iseg, ikmrk2
      real     fracs1, scals1, fracs2, scals2, fress1, fress2,
     j         fburs1, fburs2, fdigs1, fdigs2, swds1 , swds2 ,
     j         depth , switch, fracs3, scals3, b1, b2, d1, d2, r1, r2
      integer :: iswres
      integer :: isw_zf
      real    :: dms1
      real    :: dms2
      real    :: zres
      real    :: vres
      real    :: tau
      real    :: tcrrs1
      real    :: tcrrs2
      real    :: delt
      real    :: mindep
      real    :: press1
      real    :: press2
      real    :: flres1
      real    :: flres2
      real    :: rfdms1
      real    :: mrdms1
      real    :: delts2
      real    :: rfdms2
      real    :: mrdms2
      real    :: fracs1_res
      real    :: scals1_res
      real    :: fracs2_res
      real    :: scals2_res

      ip  = ipoint
!
      iflux = 0
      do 9000 iseg = 1 , noseg
      if (btest(iknmrk(iseg),0)) then
      call dhkmrk(2,iknmrk(iseg),ikmrk2)
      if ((ikmrk2.eq.0).or.(ikmrk2.eq.3)) then
!
      fracs1 = pmsa(ip( 1))
      scals1 = pmsa(ip( 2))
      fracs2 = pmsa(ip( 3))
      scals2 = pmsa(ip( 4))
      fracs3 = pmsa(ip( 5))
      scals3 = pmsa(ip( 6))
      fress1 = pmsa(ip( 7))
      fress2 = pmsa(ip( 8))
      fburs1 = pmsa(ip( 9))
      fburs2 = pmsa(ip(10))
      fdigs1 = pmsa(ip(11))
      fdigs2 = pmsa(ip(12))
      swds1  = pmsa(ip(13))
      swds2  = pmsa(ip(14))
      depth  = pmsa(ip(15))
      switch = pmsa(ip(16))
      iswres = nint(pmsa(ip(17)))
!     if iswres = 1 then the resuspension flux is independent of the other fractions and calculated here
      if ( iswres .eq. 1 ) then
         isw_zf = nint(pmsa(ip(18)))
         dms1   = pmsa(ip(19))
         dms2   = pmsa(ip(20))
         zres   = pmsa(ip(21))
         vres   = pmsa(ip(22))
         tau    = pmsa(ip(23))
         tcrrs1 = pmsa(ip(24))
         tcrrs2 = pmsa(ip(25))
         delt   = pmsa(ip(26))
         mindep = pmsa(ip(27))

         press1 = 0.0
         press2 = 0.0

!        Calculation of resuspension probability in S1
         if (tau .eq. -1.0) then
              press1 = 1.0
         else
!            Compare with critical shear stress
             press1 = max ( 0.0, (tau/tcrrs1 - 1.0) )
         endif

!        Calculation of resuspension probability in S2
         if (tau .eq. -1.0) then
            press2 = 1.0
         else
!           Compare with critical shear stress
            press2 = max ( 0.0, (tau/tcrrs2 - 1.0) )
         endif

!        Calculate resuspension

!        No resuspension when depth below min depth
         if ( depth .lt. mindep) then
            flres1 = 0.0
            flres2 = 0.0
         else
!           Resuspension from S1
            if ( isw_zf .eq. 0 ) then
               ! Add zero and first order resuspension
               rfdms1 = zres + ( vres * dms1 )
            else
               ! Take the minimum of the first order and second order
               rfdms1 = min(zres,( vres * dms1 ))
            endif

!           Limit resuspension to available material in S1
            mrdms1 = max (0.0, dms1 / delt )
            flres1 = min ( rfdms1 * press1,  mrdms1 )

!           If first layer is exhausted then resuspension from the second layer for the remaining of the timestep (DELTS2)
            if ( rfdms1*press1 .gt. 1e-20 ) then
               delts2 = max(0.0,(1.-flres1/(rfdms1*press1))*delt)
            else
               delts2 = 0.0
            endif

            if ( isw_zf .eq. 0 ) then
               rfdms2 = zres + ( vres * dms2 )
            else
               rfdms2 = min(zres,( vres * dms2 ))
            endif

!           Limit resuspension to available material in S2
            mrdms2 = max (0.0, dms2 / delt )
            flres2 = min ( rfdms2 * press2 * delts2/delt , mrdms2 )
         endif

         fress1 = flres1
         fress2 = flres2

         ! in this case the resuspension is independent of the fraction, so set fraction to 1

         fracs1_res = 1.0
         fracs2_res = 1.0
         scals1_res = 1.0
         scals2_res = 1.0
      else
         fracs1_res = fracs1
         fracs2_res = fracs2
         scals1_res = scals1
         scals2_res = scals2
      endif

!***********************************************************************
!**** Processes connected to the BURIAL and DIGGING
!***********************************************************************

!     RESUSPENSION
      R1 = 0.0
      R2 = 0.0
      IF ( FRACS1_RES*SCALS1_RES .GE. 0.0 ) R1 = FRESS1 * FRACS1_RES*SCALS1_RES
      IF ( FRACS2_RES*SCALS2_RES .GE. 0.0 ) R2 = FRESS2 * FRACS2_RES*SCALS2_RES

!     BURIAL
      B1 = 0.0
      B2 = 0.0
      IF ( FRACS1*SCALS1 .GE. 0.0 ) B1 = FBURS1 * FRACS1*SCALS1
      IF ( FRACS2*SCALS2 .GE. 0.0 ) B2 = FBURS2 * FRACS2*SCALS2

!     DIGGING
      D1 = 0.0
      D2 = 0.0
      IF ( (SWDS1 .LT. 0.5) .AND. (FRACS1*SCALS1 .GE. 0.0) ) THEN
           D1 = FDIGS1 * FRACS1*SCALS1
      ELSEIF (FRACS2*SCALS2 .GE. 0.0) THEN
           D1 = FDIGS1 * FRACS2*SCALS2
      ENDIF
      IF ( (SWDS2 .LT. 0.5) .AND. (FRACS2*SCALS2 .GE. 0.0) ) THEN
           D2 = FDIGS2 * FRACS2*SCALS2
      ELSEIF (FRACS3*SCALS3 .GE. 0.0) THEN
           D2 = FDIGS2 * FRACS3*SCALS3
      ENDIF

!     Store results

      PMSA(IP(28)) = R1
      PMSA(IP(29)) = R2
      IF (ABS(SWITCH).LT.0.5) THEN
!       NO SWITCH
        PMSA(IP(30)) = B1
        PMSA(IP(31)) = 0.0
      ELSE
!       SWITCH
        PMSA(IP(30)) = 0.0
        PMSA(IP(31)) = B1
      ENDIF
      PMSA(IP(32)) = B2
      PMSA(IP(33)) = D1
      PMSA(IP(34)) = D2

      FL( 1 + IFLUX ) = R1/DEPTH
      FL( 2 + IFLUX ) = R2/DEPTH
      IF (ABS(SWITCH).LT.0.5) THEN
!       NO SWITCH
        FL( 3 + IFLUX ) = B1/DEPTH
        FL( 4 + IFLUX ) = 0.0
      ELSE
!       SWITCH
        FL( 3 + IFLUX ) = 0.0
        FL( 4 + IFLUX ) = B1/DEPTH
      ENDIF
      FL( 5 + IFLUX ) = B2/DEPTH
      FL( 6 + IFLUX ) = D1/DEPTH
      FL( 7 + IFLUX ) = D2/DEPTH

      ENDIF
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP    = IP    + INCREM
!
 9000 CONTINUE
!
      RETURN
!
      END


#include <default_macro.h>
 program LBsoft

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! LBsoft is a specific-purpose open-source software for soft glassy
! emulsion simulations. The code was originally written by
!
! This is an experimental code. The authors accept no responsibility
! for the performance of the code or for the correctness of the results.
!
! The code is licensed under the 3-Clause BSD License (BSD-3-Clause).
! The full text of the licence can be found on the website:
! https://opensource.org/licenses/BSD-3-Clause
!
! The software development process has received funding from the
! European Research Council under the Horizon 2020 Programme
! Grant Agreement n. 739964 (COPMAT).
!
! If results obtained with this code are published, an
! appropriate citation would be:
!
!The code was originally written by
!
!Fabio Bonaccorso        IIT-CLNS, Rome                     Italy
!Marco Lauricella         IAC-CNR, Rome                     Italy
!Andrea Montessori        IAC-CNR, Rome                     Italy
!
!
!with contributions from:
!
!Giorgio Amati         CINECA-CED, Rome                     Italy
!Massimo Bernaschi        IAC-CNR, Rome                     Italy
!Sauro Succi              IAC-CNR, Rome                     Italy
!
!
!
! (May 2020)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  use fluids_lattices_mod
  use version_mod,     only : init_world,get_rank_world,get_size_world,&
                        time_world,time_world,finalize_world,idrank, &
                        setupcom,create_findneigh_list_hvar_isfluid, &
                        create_findneigh_list_pops,deallocate_ownern, &
                        create_findneigh_list_single_halo
  use profiling_mod,   only : get_memory,timer_init,itime_start, &
                        startPreprocessingTime,print_timing_partial, &
                        reset_timing_partial,printSimulationTime, &
                        print_timing_final,itime_counter,idiagnostic, &
                        ldiagnostic,start_timing2,end_timing2, &
                        startSimulationTime
  use utility_mod,     only : init_random_seed,allocate_array_buffservice3d
  use fluids_bc_mod,   only: ibctype,ixpbc,iypbc,izpbc,isfluid, &
                        driver_bc_isfluid
  use fluids_mod,      only : allocate_fluids,initialize_isfluid_bcfluid, &
                        nx,ny,nz,minx,maxx, &
                        miny,maxy,minz,maxz,lsingle_fluid, &
                        initialize_fluids, &
                        driver_initialiaze_manage_bc_selfcomm, restoreHvar, &
                        restore_oneFile

  use particles_mod,   only : allocate_particles,lparticles,vertest, &
                        initialize_map_particles,driver_inter_force, &
                        initialize_integrator_lf,initialize_particle_force, &
                        parlst, &
                        init_particles_fluid_interaction, &
                        store_old_pos_vel_part,build_new_isfluid, restorePart_oneFile
  use write_output_mod,only : write_test_map,lvtkfile,init_output, &
                        write_vtk_frame,write_xyz_close, &
                        write_particle_xyz, dumpForOutput, &
                        set_value_ivtkevery,idumpevery, &
                        read_restart_file,write_vtk_isfluid
  use integrator_mod,  only : initime,endtime,tstep,set_nstep, &
                        update_nstep,nstep,driver_integrator,nstepmax, &
                        get_restore
  use statistic_mod,   only : statistic_driver
  use io_mod

  implicit none

  integer :: IVAL=1

  real(kind=PRC) :: mytime=0.d0
  real(kind=PRC) :: itime,ctime,ftime

  real(kind=PRC) :: mymemory

  integer, allocatable, dimension(:) :: ltype_inp
  real(kind=PRC), allocatable, dimension(:) :: x_inp,y_inp,z_inp
  real(kind=PRC), allocatable, dimension(:,:) :: o_inp

  logical :: lnewlst,lrem,lremdat,ldorefinment,lrecycle,lvelocity
  logical :: wantRestore = .false.

  integer :: i,j,k,atype,nstep_rest

! set up the communications
  call init_world()

! determine processor identities
  call get_rank_world()
  call get_size_world()

! start clock
  call time_world(itime)

! print logo on terminal
  call print_logo(6)

! read the input file
  call read_input(600,'input.dat')

! setup domain decomposition
  call setupcom(nx,ny,nz,nbuff,ibctype,ixpbc,iypbc,izpbc,minx,maxx, &
   miny,maxy,minz,maxz,lsingle_fluid)

! initialize output files
  call init_output(nprintlistvtk,printlistvtk)

! set the seed
  call init_random_seed(init_seed)

! start diagnostic if requested
  if(ldiagnostic)then
    call timer_init()
    call startPreprocessingTime()
  endif

! allocate fluid arrays
  call allocate_fluids(lparticles)

#ifdef CONVERTVTK
  call set_nstep(10)
  call set_value_ivtkevery(.true., .false., 1)
  write(6,*) "Restoring hvars.."
  call restoreHvar(10)
  ! write(6,*) "Writing VTK .."
  stop
#endif

! prepare list for neighbour comm of hydrodynamic variables (also ISFLUID)
  call create_findneigh_list_hvar_isfluid(nx,ny,nz,nbuff,ibctype,ixpbc,iypbc, &
   izpbc,minx,maxx,miny,maxy,minz,maxz)

! prepare list for neighbour comm of a single halo only
  call create_findneigh_list_single_halo(nx,ny,nz,nbuff,ibctype,ixpbc,iypbc, &
   izpbc,minx,maxx,miny,maxy,minz,maxz)

! initialize isfluid and bcfluid (type of node and bc adopted)
  call initialize_isfluid_bcfluid(lvtkfile, lparticles)

! allocate pointers for managing bc hvar and pops within the same process
! ONLY if it is necessary
  call driver_initialiaze_manage_bc_selfcomm

! prepare list for neighbour comm of fluid pops
  call create_findneigh_list_pops(nx,ny,nz,nbuff,ibctype,isfluid, &
   ixpbc,iypbc,izpbc,minx,maxx,miny,maxy,minz,maxz)

! allocate service array
  call allocate_array_buffservice3d(minx-nbuff,maxx+nbuff,miny-nbuff, &
   maxy+nbuff,minz-nbuff,maxz+nbuff)

  if(lparticles) then
    ! read input xyz file if necessary
    call read_input_atom(700,'input.xyz',ltype_inp,x_inp,y_inp,z_inp,o_inp, &
        lvelocity)

    ! allocate particle arrays
    call allocate_particles(ibctype,tstep)

    ! initialize and decompose the particle domain
    call initialize_map_particles(nxyzlist,xyzlist,ltype_inp,x_inp,y_inp,z_inp, &
        o_inp,lvelocity)
  endif

! at this point you can deallocate ownern in order to release space
#ifdef DEOWERN
  call deallocate_ownern
#endif

! allocate service arrays for printing modules
  call allocate_print()

! initialize the counter of the integration steps
  call set_nstep(0)

! initialize the time of the integration steps
  mytime=initime

! initialize and read the restart file if requested
  call initialize_fluids

! restore
  call get_restore(wantRestore)
  if (wantRestore) then
    call read_restart_file(135,'dumpGlobal.restart.dat',nstep_rest)
    call set_nstep(nstep_rest)
    mytime=real(nstep,kind=PRC)*tstep
    call restore_oneFile(nstep)
    if(lparticles) call restorePart_oneFile(nstep)
  endif

! initialize particle fluid interaction if requested
  call init_particles_fluid_interaction(wantRestore)

! print memory
  call get_memory(mymemory)
  call print_memory_registration(6,'memory occupied after allocation', &
   mymemory)

! open the  output 'statdat.dat' file and print first record on terminal
! and output file
  !call outprint_driver(nstep,mytime)

! open the binary file (only for developers)
  !call open_dat_file(lprintdat,130,'traj.dat')

  call write_vtk_frame(0,wantRestore)
  if(.not. wantRestore)call write_vtk_isfluid(0)

! interpolate the particle velocity at half timestep back to apply lf
  if(lparticles)then
    call vertest(nstep, lnewlst)
    if(lnewlst) call parlst(nstep, .true.)
    call initialize_particle_force
    if (.not. wantRestore) then
      call driver_inter_force(nstep, .true.)
      call initialize_integrator_lf
      call store_old_pos_vel_part
    endif
    call driver_bc_isfluid
  endif

! initialize lrecycle
  lrecycle=(nstep<nstepmax)
  mytime=real(nstep,kind=PRC)*tstep
  if(.not. lrecycle)call dumpForOutput(nstep,mytime,.false.)

! start diagnostic if requested
  if(ldiagnostic)then
    call print_timing_partial(1,1,itime_start,IOOUT)
    call reset_timing_partial()
    call startSimulationTime()
  endif

!max  write(0,*)'Going to sleep...',idrank
!max  call sleep(30)
!***********************************************************************
!     start the time integration
!***********************************************************************
  do while (lrecycle)

!   update the counter
    call update_nstep

    mytime=real(nstep,kind=PRC)*tstep

!   check recycle loop
    lrecycle=(nstep<nstepmax)

!   integrate the system
    call driver_integrator(mytime)

!   compute statistical quantities
    call statistic_driver(nstep,mytime)

!   print on the binary file the jet bead which have hit the collector
!   (only for developers)
    !call write_datrem_frame(lprintdat,122,nstep,mytime,iprintdat, &
    ! inpjet,npjet,sprintdat,systype,lremdat,nremoved)

!   print data on terminal
    if(ldiagnostic)call start_timing2("IO","outprint_driver")
    call outprint_driver(nstep,mytime)
    if(ldiagnostic)call end_timing2("IO","outprint_driver")

!   dump outdata and print restart file
    if(ldiagnostic)call start_timing2("IO","dump_stats")
    call dumpForOutput(nstep,mytime,.false.)
    if(ldiagnostic)call end_timing2("IO","dump_stats")

!   cycle time check
    call time_world(ctime)

!   check recycle loop
    lrecycle=(lrecycle .and. timjob-ctime>timcls)

  enddo
!***********************************************************************
!     end of the time integration
!***********************************************************************

! stop clock
  call time_world(ftime)

! print final memory
  call get_memory(mymemory)
  call print_memory_registration(6,'memory occupied at the end', &
   mymemory)

! print final particle coordinates
  call write_particle_xyz

! print restart file
  call dumpForOutput(nstep,mytime,.true.)

! close the XYZ formatted output file
  !call close_xyz_file(lprintxyz,120)

! close the binary file for hit beads (only for developers)
  !call close_datrem_file(lprintdat,122)

! close the binary file (only for developers)
  !call close_dat_file(lprintdat,130)

! finalize and print the diagnostic data
  if(ldiagnostic)then
    call printSimulationTime()
    call print_timing_final(idiagnostic,itime_counter,itime_start,1,1,IOOUT)
  endif

  !call write_test_map

  call write_xyz_close

  if(idrank==0)write(6,'(a)')'Programm exit correctly'

! close the communications
  call finalize_world()

  stop

 end program LBsoft


      SUBROUTINE vegasnr(region,ndim,fxn,init,ncall,itmx,nprn,tgral,sd,
     *chi2a)
      implicit none
      include 'mxdim.f'
      include 'gridinfo.f'
      include 'maxwt.f'
      include 'nf.f'
      include 'TRtensorcontrol.f'
      include 'tensorinfo.f'
      include 'mxpart.f'
      include 'phasemin.f'
      include 'cutoff.f'
      include 'jetcuts.f'
      include 'breit.f'
      include 'zerowidth.f'
      include 'srdiags.f'
      include 'interference.f'
      include 'qcdcouple.f'
      include 'ewcouple.f'
      include 'masses.f'
      include 'ipsgen.f'
      include 'scale.f'
      include 'stopscales.f'
      include 'qlfirst.f'
      include 'ptilde.f'
      include 'bitflags.f'
      include 'flags.f'
      include 'lastphot.f'
      include 'b0.f'
      include 'nodecay.f'
      include 'swapxz.f'
      include 'heavyflav.f'
      include 'nflav.f'
      include 'notag.f'
      include 'reset.f'
      include 'lc.f'

      INTEGER init,itmx,ncall,ndim,nprn,NDMX
      DOUBLE PRECISION tgral,chi2a,sd,region(2*mxdim),fxn,ALPH,TINY
c--- Note: NDMX increased to 100 (from 50) compared with versions 5.1 and
c---  earlier, to aid calculation of H+2 jets process
      PARAMETER (ALPH=1.5d0,NDMX=100,TINY=1d-30)
c--- DEBUG: no adapting
c      PARAMETER (ALPH=0d0,NDMX=100,TINY=1d-30)
      EXTERNAL fxn
C     USES fxn,ran2,rebin
      INTEGER i,l,idum,it,j,k,jj,mds,nd,ndo,ng,npg,ia(MXDIM),kg(MXDIM)
      DOUBLE PRECISION calls,dv2g,dxg,f,f2,f2b,fb,rc,ti,tsi,wgt,xjac,
     *xxn,xnd,xo,
     *d(NDMX,MXDIM),di(NDMX,MXDIM),dt(MXDIM),dx(MXDIM),r(NDMX),x(MXDIM),
     *xi(NDMX,MXDIM),xin(NDMX),ran2
      DOUBLE PRECISION schi,si,swgt,p1ext(4),p2ext(4)
      double precision t,ct,cfun,cfun2,cd(NDMX,MXDIM),cdi(NDMX,MXDIM)
      character*255 runname
      integer nlength
      logical bin,dorebin,dryrun,kahan
      common/bin/bin
      common/runname/runname
      common/nlength/nlength
      common/dryrun/dryrun
      COMMON /ranno/ idum
      common/pext/p1ext,p2ext
!$omp threadprivate(/pext/)
      parameter(kahan=.false.)
      SAVE

      dorebin=.true.
      mds=0
      if(init.le.0)then
        ndo=1
        do 11 j=1,ndim
          xi(1,j)=1d0
11      continue
      endif
      if (init.le.1)then
        si=0d0
        swgt=0d0
        schi=0d0
      endif
      if (init.le.2)then
        nd=NDMX
        ng=1
c--- DEBUG
c        write(6,*) 'DEBUG: Setting mds to zero'
c        mds=0
c--- DEBUG
        if(mds.ne.0)then
          ng=(ncall/2d0+0.25d0)**(1d0/ndim)
          mds=1
          if((2*ng-NDMX).ge.0)then
            mds=-1
            npg=ng/NDMX+1
            nd=ng/npg
            ng=npg*nd
          endif
        endif
        k=ng**ndim
        npg=max(ncall/k,2)
        calls=npg*k
        dxg=1d0/ng
        dv2g=(calls*dxg**ndim)**2/npg/npg/(npg-1d0)
        xnd=nd
        dxg=dxg*xnd
        xjac=1d0/calls
        do 12 j=1,ndim
          dx(j)=region(j+ndim)-region(j)
          xjac=xjac*dx(j)
12      continue

c--- read-in grid if necessary
        if (readin) then
           if (dryrun) then
             open(unit=11,file=ingridfile,status='unknown')
           else
             open(unit=11,file=runname(1:nlength)//'_'
     .             //ingridfile,status='unknown')
           endif
        write(6,*)'****************************************************'
        write(6,*)'* Reading in vegas grid from ',runname(1:nlength)//
     .   '_'//ingridfile,' *'
        write(6,*)'****************************************************'
           call flush(6)
           do j=1,ndim
             read(11,203) jj,(xi(i,j),i=1,nd)
           enddo
           close(11)
           ndo=nd
           readin=.false.
c--- do not continue to adapt grid when using a small number of calls
           if (calls .lt. 1d3) then
             write(6,*)
             write(6,*) '--> Small number of calls, so the grid is not',
     .        ' being adjusted after each iteration <--'
             write(6,*)
             call flush(6)
             dorebin=.false.
           endif
        endif

        if(nd.ne.ndo)then
          do 13 i=1,nd
            r(i)=1d0
13        continue
          do 14 j=1,ndim
            call rebin(ndo/xnd,nd,r,xin,xi(1,j))
14        continue
          ndo=nd
        endif
        if(nprn.ge.0) write(6,200) ndim,calls,it,itmx,nprn,ALPH,mds,nd,
     *(j,region(j),j,region(j+ndim),j=1,ndim)
        call flush(6)
      endif

      do 28 it=1,itmx
        ti=0d0
        tsi=0d0
        do 16 j=1,ndim
          kg(j)=1
          do 15 i=1,nd
            d(i,j)=0d0
            di(i,j)=0d0
15        continue
16      continue
10      continue
        fb=0d0
        f2b=0d0
        if (kahan) then
           cfun = 0d0
           cfun2 = 0d0
           cd(:,:)=0d0
           cdi(:,:)=0d0
        endif
!$omp  parallel do
!$omp& schedule(dynamic)
!$omp& default(private)
!$omp& shared(npg,xjac,ncall,ndim,kg,dxg,xi,region,dx,xnd,fb,f2b,di,d)
!$omp& shared(cfun,cfun2,cd,cdi)
!$omp& copyin(/xmin/,/taumin/,/cutoff/,/jetcuts/,/breit/,/zerowidth/)
!$omp& copyin(/srdiags/,/vsymfact/,/qcdcouple/,/ewcouple/,/masses/)
!$omp& copyin(/interference/,/ipsgen/,/scale/,/stopscales/)
!$omp& copyin(/pext/,/ColC/,/qlfirst/,/ptildes/)
!$omp& copyin(/bitflags/,/flags/,/lastphot/)
!$omp& copyin(/QCDb0/,/nodecay/,/swapxz/,/heavyflav/)
!$omp& copyin(/notag/,/nflav/,/reset/)
          do 19 k=1,npg
            wgt=xjac
!$omp critical(VegasRandom)
c--- note: added (ndim+1) to use as random variable for PS branches
c--- note: added (ndim+2) to use as random variable in new_pspace
          do l=1,ndim+2
           x(l)=ran2()
!           x(l)=1d0-ran2() ! this way, agrees with vegas_Pomp
        enddo
!$omp end critical(VegasRandom)
        do 17 j=1,ndim
              xxn=(kg(j)-x(j))*dxg+1d0
              ia(j)=max(min(int(xxn),NDMX),1)
              if(ia(j).gt.1)then
                xo=xi(ia(j),j)-xi(ia(j)-1,j)
                rc=xi(ia(j)-1,j)+(xxn-ia(j))*xo
              else
                xo=xi(ia(j),j)
                rc=(xxn-ia(j))*xo
              endif
              x(j)=region(j)+rc*dx(j)
              wgt=wgt*xo*xnd
 17        continue
            f=wgt*fxn(x,wgt)
            f2=f*f
!$omp critical(VegasAdd)
            if (kahan) then
               t=fb+f
               if (abs(fb).ge.abs(f)) then
                  cfun=cfun+((fb-t)+f)
               else
                  cfun=cfun+((f-t)+fb)
               endif
               fb=t
               t=f2b+f2
               if (abs(f2b).ge.abs(f2)) then
                  cfun2=cfun2+((f2b-t)+f2)
               else
                  cfun2=cfun2+((f2-t)+f2b)
               endif
               f2b=t
               do j = 1, ndim
                  i=ia(j)
                  ct=di(i,j)
                  t=ct+f
                  if (abs(ct).ge.abs(f)) then
                     cdi(i,j)=cdi(i,j)+((ct-t)+f)
                  else
                     cdi(i,j)=cdi(i,j)+((f2-t)+ct)
                  endif
                  di(i,j)=t
               enddo
               if (mds.ge.0) then
                  do j = 1, ndim
                     i=ia(j)
                     ct=d(i,j)
                     t=ct+f2
                     if (abs(ct).ge.abs(f2)) then
                        cd(i,j)=cd(i,j)+((ct-t)+f2)
                     else
                        cd(i,j)=cd(i,j)+((f2-t)+ct)
                     endif
                     d(i,j)=t
                  enddo
               endif
            else
               fb=fb+f
               f2b=f2b+f2
               do 18 j=1,ndim
                  di(ia(j),j)=di(ia(j),j)+f
                  if(mds.ge.0) d(ia(j),j)=d(ia(j),j)+f2
 18            continue
            endif
!$omp end critical(VegasAdd)
19        continue
!$omp end parallel do
          if (kahan) then
             fb=fb+cfun
             f2b=f2b+cfun2
             di(:,:)=di(:,:)+cdi(:,:)
             d(:,:)=d(:,:)+cd(:,:)
          endif
          f2b=dsqrt(f2b*npg)
          f2b=(f2b-fb)*(f2b+fb)
          if (f2b.le.0d0) f2b=TINY
          ti=ti+fb
          tsi=tsi+f2b
          if(mds.lt.0)then
            do 21 j=1,ndim
              d(ia(j),j)=d(ia(j),j)+f2b
21          continue
          endif
        do 22 k=ndim,1,-1
          kg(k)=mod(kg(k),ng)+1
          if(kg(k).ne.1) goto 10
22      continue
        tsi=tsi*dv2g
        wgt=1d0/tsi
        si=si+dble(wgt)*dble(ti)
        schi=schi+dble(wgt)*dble(ti)**2
        swgt=swgt+dble(wgt)
        tgral=si/swgt
        chi2a=max((schi-si*tgral)/(it-.99d0),0d0)
        sd=dsqrt(1d0/swgt)
        tsi=dsqrt(tsi)
        if(nprn.ge.0)then
c          write(6,201) it,ti,tsi,tgral,sd,chi2a
          write(6,201) it,ti,tgral,tsi,sd,wtmax,chi2a
          if (TRtensorcontrol .gt. 0) then
          write(6,301) dfloat(ibadpoint)/dfloat(itotal),
     &                 dfloat(ipolesfailed)/dfloat(itotal),
     &                 dfloat(ibadpoint+ipolesfailed)/dfloat(itotal)
          endif
          call flush(6)
         if(nprn.ne.0)then
            do 23 j=1,ndim
              write(6,202) j,(xi(i,j),di(i,j),i=1+nprn/2,nd,nprn)
23          continue
          endif
        endif
        if (abs(tgral) .lt. 1d-9) then
          write(6,*) '******** Integral is zero, no more iterations '
     &      //'required *********'
          write(6,*)
          tgral=0d0
          sd=0d0
          call flush(6)
          exit ! bail early (28) if result is zero
        endif
        do 25 j=1,ndim
          xo=d(1,j)
          xxn=d(2,j)
          d(1,j)=(xo+xxn)/2d0
          dt(j)=d(1,j)
          do 24 i=2,nd-1
            rc=xo+xxn
            xo=xxn
            xxn=d(i+1,j)
            d(i,j)=(rc+xxn)/3d0
            dt(j)=dt(j)+d(i,j)
24        continue
          d(nd,j)=(xo+xxn)/2d0
          dt(j)=dt(j)+d(nd,j)
25      continue
        do 27 j=1,ndim
           rc=0d0
           do 26 i=1,nd
            if(d(i,j).lt.TINY) d(i,j)=TINY
            r(i)=((1d0-d(i,j)/dt(j))/(dlog(dt(j))-dlog(d(i,j))))**ALPH
            rc=rc+r(i)
26        continue
          if (dorebin) call rebin(rc/xnd,nd,r,xin,xi(1,j))
27      continue
c--- added to write out intermediate results
      if ((bin) .and. (it .lt. itmx)) then
        write(6,*) 'Writing out intermediate results for iteration',it
        call histofin(tgral,sd,it,itmx)
      endif
28    continue

c--- write-out grid if necessary
         if (writeout) then
           open(unit=11,file=runname(1:nlength)//'_'
     .           //outgridfile,status='unknown')
        write(6,*)'****************************************************'
        write(6,*)'* Writing out vegas grid to ',runname(1:nlength)//'_'
     .           //outgridfile,'  *'
        write(6,*)'****************************************************'
           call flush(6)
           do j=1,ndim
             write(11,203) j,(xi(i,j),i=1,nd)
           enddo
           close(11)
         endif

      return

200   FORMAT(/' input parameters for vegas:  ndim=',i3,'  ncall=',
     *f8.0/28x,'  it=',i5,'  itmx=',i5/28x,'  nprn=',i3,'  alph=',
     *f5.2/28x,'  mds=',i3,'   nd=',i4/(30x,'xl(',i2,')= ',g11.4,' xu(',
     *i2,')= ',g11.4))
c201   FORMAT(/' iteration no.',I3,': ','integral =',g14.7,'+/- ',g9.2/
c     *' all iterations:   integral =',g14.7,'+/- ',g9.2,' chi**2/iter',
c     * g9.2)
 201    format(/'************* Integration by Vegas (iteration ',i3,
     .   ') **************' / '*',63x,'*'/,
     .   '*  integral  = ',g14.8,2x,
     .   ' accum. integral = ',g14.8,'*'/,
     .   '*  std. dev. = ',g14.8,2x,
     .   ' accum. std. dev = ',g14.8,'*'/,
     .   '*   max. wt. = ',g14.6,35x,'*'/,'*',63x,'*'/,
     .   '**************   chi**2/iteration = ',
     .   g10.4,'   ****************' /)
301     format('> TensorRed:   TensF',e9.2,
     &    ' / PolF',e9.2,' / TotalF',e9.2,' <'/)
202   FORMAT(/' data for axis ',I2/'    X       delta i       ',
     *'   x       delta i       ','    x       delta i       ',/(1x,
     *f7.5,1x,g11.4,5x,f7.5,1x,g11.4,5x,f7.5,1x,g11.4))
203   FORMAT(/(5z16))
      END
C  (C) Copr. 1986-92 Numerical Recipes Software =v1.9"217..

      SUBROUTINE rebin(rc,nd,r,xin,xi)
      implicit none
      INTEGER nd
      DOUBLE PRECISION rc,r(*),xi(*),xin(*)
      INTEGER i,k
      DOUBLE PRECISION dr,xxn,xo
      k=0
      xxn=0d0
      dr=0d0
      do 11 i=1,nd-1
1       if(rc.gt.dr)then
          k=k+1
          dr=dr+r(k)
          xo=xxn
          xxn=xi(k)
        goto 1
        endif
        dr=dr-rc
        xin(i)=xxn-(xxn-xo)*dr/r(k)
11    continue
      do 12 i=1,nd-1
        xi(i)=xin(i)
12    continue
      xi(nd)=1d0
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software =v1.9"217..


	SUBROUTINE GH_RDDS ( advise, lenw, slat, slon, wdir, wsped,
     +                       wpres, wwnd, tmptim, idisp, iret )
C************************************************************************
C* GH_RDDS 								*
C*									*
C* This subroutine determins if the tropical storm is dissipating at	*
C* the current advisory time.						*
C*                                                                      *
C* GH_RDDS ( ADVISE, LENW, SLAT, SLON, WDIR, WSPED, WPRES, WWND,        *
C*           TMPTIM, IDISP, IRET ) 					*
C*									*
C* Input parameters:							*
C*	ADVISE		CHAR*		Report advisory bulletin	*
C*	LENW		INTEGER		Length of bulletin              *
C*	SLAT 		REAL		Latitude of points              *
C*	SLON 		REAL		Longitude of points             *
C*	WDIR 		CHAR*		Direction of storm movement(deg)*
C*	WSPED 		CHAR*		Speed of movement (knots)	*
C*	WPRES 		CHAR*		Minimum central pressure (mb)   *
C*	WWND		CHAR*		Max sustained wind		*
C*	TMPTIM		CHAR*		Valid location time		*
C*									*
C* Output parameters:							*
C*	IDISP		INTEGER		Storm dissipation flag		*
C*					  2 = label, marker, statement	*
C*					  1 = marker, statement		*
C*					  0 = label,marker (normal map)	*
C*					 -1 = statement			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*									*
C**									*
C* Log:									*
C* A. Hardy/GSC		 5/01						*
C* A. Hardy/GSC		 6/01		Cleaned up prolog		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
        INCLUDE         'BRIDGE.PRM'
C*
	CHARACTER*(*)	advise,  wdir, wsped, wpres, wwnd, tmptim
C*
	LOGICAL         label, mrkr, hvdis
C------------------------------------------------------------------------
        iret = 0
        mrkr  = .true.
        label = .true.
        hvdis = .false.
C
C*      Search for dissipating in report.
C
	CALL ST_LSTR ( tmptim, lent, ier)
        CALL ST_NOCC (advise (:lenw), tmptim(:lent), 2, ipoint, ier )
	idiss = INDEX( advise(ipoint:lenw), 'DISSIP' )
        IF ( idiss .gt. 0 ) hvdis = .true.
C
C*	Verify valid storm information.
C
        CALL ST_NUMB ( wdir, idir, ier )
        CALL ST_NUMB ( wsped, isped, ier )
C
C*      Missing current location information.
C
	IF ( ( slat .eq. RMISSD) .or. ( slon .eq. RMISSD ) ) THEN
               mrkr = .false.
               label = .false.
        END IF
C
C*      Missing storm information.
C
	IF ( ( idir .lt. 0 ) .or. ( isped .lt. 0 ) .or.
     +       ( wpres(:3) .eq. 'XXX') .or. (wwnd(:3) .eq. 'XXX' ) ) THEN
               label = .false.
        END IF
C
C*      Determine if label box, current location or dissipation
C*      statement gets plotted.
C
	IF ( ( .not. hvdis ) .and. ( label ) .and. ( mrkr ) ) THEN
            idisp = 0
	  ELSE IF ( ( hvdis ) .and. ( .not. label ) .and.
     +                                        ( .not. mrkr ) ) THEN
            idisp = -1
	  ELSE IF ( ( hvdis ) .and. ( .not. label ) .and.
     +                                              ( mrkr ) ) THEN
            idisp = 1
	  ELSE IF ( ( hvdis ) .and. ( label ) .and. ( mrkr ) ) THEN
            idisp = 2
        END IF
C*
	RETURN
	END


C$Procedure      SPKW08 ( Write SPK segment, type 8 )

      SUBROUTINE SPKW08 (  HANDLE,  BODY,    CENTER,  FRAME,
     .                     FIRST,   LAST,    SEGID,   DEGREE,
     .                     N,       STATES,  EPOCH1,  STEP     )

C$ Abstract
C
C     Write a type 8 segment to an SPK file.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     NAIF_IDS
C     SPC
C     SPK
C     TIME
C
C$ Keywords
C
C     EPHEMERIS
C     FILES
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'spk08.inc'

      INTEGER               HANDLE
      INTEGER               BODY
      INTEGER               CENTER
      CHARACTER*(*)         FRAME
      DOUBLE PRECISION      FIRST
      DOUBLE PRECISION      LAST
      CHARACTER*(*)         SEGID
      INTEGER               DEGREE
      INTEGER               N
      DOUBLE PRECISION      STATES ( 6, * )
      DOUBLE PRECISION      EPOCH1
      DOUBLE PRECISION      STEP

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     MAXDEG     P   Maximum degree of interpolating polynomials.
C     TOLSCL     P   Scale factor used to compute time bound tolerance.
C     HANDLE     I   Handle of an SPK file open for writing.
C     BODY       I   NAIF code for an ephemeris object.
C     CENTER     I   NAIF code for center of motion of BODY.
C     FRAME      I   Reference frame name.
C     FIRST      I   Start time of interval covered by segment.
C     LAST       I   End time of interval covered by segment.
C     SEGID      I   Segment identifier.
C     DEGREE     I   Degree of interpolating polynomials.
C     N          I   Number of states.
C     STATES     I   Array of states.
C     EPOCH1     I   Epoch of first state in STATES array.
C     STEP       I   Time step separating epochs of states.
C     MAXDEG     P   Maximum allowed degree of interpolating polynomial.
C
C$ Detailed_Input
C
C     HANDLE         is the file handle of an SPK file that has been
C                    opened for writing.
C
C     BODY           is the NAIF integer code for an ephemeris object
C                    whose state relative to another body is described
C                    by the segment to be created.
C
C     CENTER         is the NAIF integer code for the center of motion
C                    of the object identified by BODY.
C
C     FRAME          is the NAIF name for a reference frame
C                    relative to which the state information for BODY
C                    is specified.
C
C     FIRST,
C     LAST           are, respectively, the start and stop times of
C                    the time interval over which the segment defines
C                    the state of BODY.
C
C     SEGID          is the segment identifier.  An SPK segment
C                    identifier may contain up to 40 characters.
C
C     DEGREE         is the degree of the Lagrange polynomials used to
C                    interpolate the states.  All components of the
C                    state vectors are interpolated by polynomials of
C                    fixed degree.
C
C     N              is the number of states in the input state vector
C                    array.
C
C     STATES         contains a time-ordered array of geometric states
C                    ( x, y, z, dx/dt, dy/dt, dz/dt, in kilometers and
C                    kilometers per second ) of BODY relative to CENTER,
C                    specified relative to FRAME.
C
C     EPOCH1         is the epoch corresponding to the first state in
C                    the state array.  Because extra states are needed
C                    at the beginning and end of the segment in order
C                    for the interpolation method to work, EPOCH1 will
C                    normally precede FIRST.
C
C     STEP           is the time step separating the epochs of adjacent
C                    states in the input state array.  STEP is specified
C                    in seconds.
C
C$ Detailed_Output
C
C     None.  See $Particulars for a description of the effect of this
C     routine.
C
C$ Parameters
C
C     See the include file spk08.inc for declarations of the
C     parameters described below.
C
C     MAXDEG         is the maximum degree of Lagrange polynomials that
C                    can be used to interpolate states from the segment
C                    written by this routine.
C
C     TOLSCL         is a tolerance scale factor (also called a
C                    "relative tolerance") used for time coverage
C                    bound checking. TOLSCL is unitless. TOLSCL
C                    produces a tolerance value via the formula
C
C                       TOL = TOLSCL * MAX( ABS(FIRST), ABS(LAST) )
C
C                    where FIRST and LAST are the coverage time bounds
C                    of a type 8 segment, expressed as seconds past
C                    J2000 TDB.
C
C                    The resulting parameter TOL is used as a tolerance
C                    for comparing the input segment descriptor time
C                    bounds to the first and last epoch covered by the
C                    sequence of time intervals defined by the inputs
C                    to SPKW08:
C
C                       EPOCH1
C                       STEP
C                       N
C
C$ Exceptions
C
C     If any of the following exceptions occur, this routine will return
C     without creating a new segment.
C
C     1) If FRAME is not a recognized name, the error
C        SPICE(INVALIDREFFRAME) is signaled.
C
C     2) If the last non-blank character of SEGID occurs past index 40,
C        the error SPICE(SEGIDTOOLONG) is signaled.
C
C     3) If SEGID contains any nonprintable characters, the error
C        SPICE(NONPRINTABLECHARS) is signaled.
C
C     4) If DEGREE is not at least 1 or is greater than MAXDEG, the
C        error SPICE(INVALIDDEGREE) is signaled.
C
C     5) If the number of states N is not at least DEGREE+1, the error
C        SPICE(TOOFEWSTATES) will be signaled.
C
C     6) If FIRST is greater than LAST then the error
C        SPICE(BADDESCRTIMES) will be signaled.
C
C     7) If STEP is non-positive, the error SPICE(INVALIDSTEPSIZE) will
C        be signaled.
C
C     8) If the start time of the first record exceeds the descriptor
C        begin time by more than a computed tolerance, or if the end
C        time of the last record precedes the descriptor end time by
C        more than a computed tolerance, the error SPICE(COVERAGEGAP)
C        is signaled. See the Parameters section above for a
C        description of the tolerance.
C
C$ Files
C
C     A new type 8 SPK segment is written to the SPK file attached
C     to HANDLE.
C
C$ Particulars
C
C     This routine writes an SPK type 08 data segment to the open SPK
C     file according to the format described in the type 08 section of
C     the SPK Required Reading. The SPK file must have been opened with
C     write access.
C
C$ Examples
C
C     Suppose that you have states and are prepared to produce
C     a segment of type 08 in an SPK file.
C
C     The following code fragment could be used to add the new segment
C     to a previously opened SPK file attached to HANDLE. The file must
C     have been opened with write access.
C
C            C
C            C     Create a segment identifier.
C            C
C                  SEGID = 'MY_SAMPLE_SPK_TYPE_8_SEGMENT'
C
C            C
C            C     Write the segment.
C            C
C                  CALL SPKW08 (  HANDLE,  BODY,    CENTER,  FRAME,
C                .                FIRST,   LAST,    SEGID,   DEGREE,
C                .                N,       STATES,  EPOCH1,  STEP     )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     K.R. Gehringer (JPL)
C     N.J. Bachman   (JPL)
C     J.M. Lynch     (JPL)
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 3.0.0, 11-JAN-2013 (NJB)
C
C        Relaxed test on relationship between the time bounds of the
C        input record set (determined by EPOCH1, STEP, and N) and the
C        descriptor bounds FIRST and LAST. Now the descriptor bounds
C        may extend beyond the time bounds of the record set by a ratio
C        computed using the parameter TOLSCL (see Parameters above for
C        details). MAXDEG was increased to 27.
C
C-    SPICELIB Version 2.0.0, 19-SEP-1995 (WLT)
C
C        The routine was upgraded to support non-inertial reference
C        frames.
C
C-    SPICELIB Version 1.0.1, 05-OCT-1993 (KRG)
C
C        Removed all references to a specific method of opening the SPK
C        file in the $ Brief_I/O, $ Detailed_Input, $ Particulars and
C        $ Examples sections of the header. It is assumed that a person
C        using this routine has some knowledge of the DAF system and the
C        methods for obtaining file handles.
C
C-    SPICELIB Version 1.0.0, 08-AUG-1993 (NJB) (JML) (WLT)
C
C-&

C$ Index_Entries
C
C     write spk type_8 ephemeris data segment
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.0.0, 19-SEP-1995 (WLT)
C
C        The routine was upgraded to support non-inertial reference
C        frames.
C
C-    SPICELIB Version 1.0.1, 05-OCT-1993 (KRG)
C
C        Removed all references to a specific method of opening the SPK
C        file in the $ Brief_I/O, $ Detailed_Input, $ Particulars and
C        $ Examples sections of the header. It is assumed that a person
C        using this routine has some knowledge of the DAF system and the
C        methods for obtaining file handles.
C
C-    SPICELIB Version 1.0.0, 08-AUG-1993 (NJB) (JML) (WLT)
C
C-&

C
C     SPICELIB functions
C
      INTEGER               LASTNB

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C

C
C     SIDLEN is the maximum number of characters allowed in an
C     SPK segment identifier.
C
C     NS is the size of a packed SPK segment descriptor.
C
C     ND is the number of double precision components in an SPK
C     segment descriptor.
C
C     NI is the number of integer components in an SPK segment
C     descriptor.
C
C     DTYPE is the data type.
C
C     FPRINT is the integer value of the first printable ASCII
C     character.
C
C     LPRINT is the integer value of the last printable ASCII character.
C
C
      INTEGER               SIDLEN
      PARAMETER           ( SIDLEN =  40 )

      INTEGER               NS
      PARAMETER           ( NS     =   5 )

      INTEGER               ND
      PARAMETER           ( ND     =   2 )

      INTEGER               NI
      PARAMETER           ( NI     =   6 )

      INTEGER               DTYPE
      PARAMETER           ( DTYPE  =   8 )

      INTEGER               FPRINT
      PARAMETER           ( FPRINT =  32 )

      INTEGER               LPRINT
      PARAMETER           ( LPRINT = 126 )

      INTEGER               STATSZ
      PARAMETER           ( STATSZ =   6 )

      INTEGER               TIMLEN
      PARAMETER           ( TIMLEN =  40 )

C
C     Local variables
C
      CHARACTER*(TIMLEN)    ETSTR

      DOUBLE PRECISION      DCD    ( ND )
      DOUBLE PRECISION      DESCR  ( NS )
      DOUBLE PRECISION      LTIME
      DOUBLE PRECISION      TOL

      INTEGER               CHRCOD
      INTEGER               I
      INTEGER               ICD    ( NI )
      INTEGER               REFCOD

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'SPKW08' )

C
C     Get the NAIF integer code for the reference frame.
C
      CALL NAMFRM ( FRAME, REFCOD )

      IF ( REFCOD .EQ. 0 ) THEN

         CALL SETMSG ( 'The reference frame # is not supported.'   )
         CALL ERRCH  ( '#', FRAME                                  )
         CALL SIGERR ( 'SPICE(INVALIDREFFRAME)'                    )
         CALL CHKOUT ( 'SPKW08'                                    )
         RETURN

      END IF

C
C     Check to see if the segment identifier is too long.
C
      IF ( LASTNB(SEGID) .GT. SIDLEN ) THEN

         CALL SETMSG ( 'Segment identifier contains more than ' //
     .                 '40 characters.'                          )
         CALL SIGERR ( 'SPICE(SEGIDTOOLONG)'                     )
         CALL CHKOUT ( 'SPKW08'                                  )
         RETURN

      END IF

C
C     Now check that all the characters in the segment identifier
C     can be printed.
C
      DO I = 1, LASTNB(SEGID)

         CHRCOD = ICHAR( SEGID(I:I) )

         IF ( ( CHRCOD .LT. FPRINT ) .OR. ( CHRCOD .GT. LPRINT ) ) THEN

            CALL SETMSG ( 'The segment identifier contains '
     .               //   'nonprintable characters: ICHAR(SEGID(#:#)) '
     .               //   ' = #'                                  )
            CALL ERRINT ( '#',   I                                )
            CALL ERRINT ( '#',   I                                )
            CALL ERRINT ( '#',   CHRCOD                           )
            CALL SIGERR ( 'SPICE(NONPRINTABLECHARS)'              )
            CALL CHKOUT ( 'SPKW08'                                )
            RETURN

         END IF

      END DO

C
C     Make sure that the degree of the interpolating polynomials is
C     in range.
C
      IF (  ( DEGREE .LT. 1 ) .OR. ( DEGREE .GT. MAXDEG )  )  THEN

         CALL SETMSG ( 'The interpolating polynomials have degree #; '//
     .                 'the valid degree range is [1, #].'             )
         CALL ERRINT ( '#', DEGREE                                     )
         CALL ERRINT ( '#', MAXDEG                                     )
         CALL SIGERR ( 'SPICE(INVALIDDEGREE)'                          )
         CALL CHKOUT ( 'SPKW08'                                        )
         RETURN

      END IF

C
C     Make sure that the number of states is sufficient to define a
C     polynomial whose degree is DEGREE.
C
      IF ( N .LE. DEGREE ) THEN

         CALL SETMSG ( 'At least # states are required to define a '  //
     .                 'polynomial of degree #.  Number of states '   //
     .                 'supplied:  #.'                                 )
         CALL ERRINT ( '#', DEGREE + 1                                 )
         CALL ERRINT ( '#', DEGREE                                     )
         CALL ERRINT ( '#', N                                          )
         CALL SIGERR ( 'SPICE(TOOFEWSTATES)'                           )
         CALL CHKOUT ( 'SPKW08'                                        )
         RETURN

      END IF

C
C     The segment stop time should be greater than the begin time.
C
      IF ( FIRST .GE. LAST ) THEN

         CALL SETMSG ( 'The segment start time: # is greater than ' //
     .                 'or equal to the segment end time: #'       )
         CALL ERRDP  ( '#', FIRST                                  )
         CALL ERRDP  ( '#', LAST                                   )
         CALL SIGERR ( 'SPICE(BADDESCRTIMES)'                      )
         CALL CHKOUT ( 'SPKW08'                                    )
         RETURN

      END IF

C
C     The step size must be positive.
C
      IF ( STEP .LE. 0.D0 ) THEN

         CALL SETMSG ( 'The step size must be > 0 but was #. ' )
         CALL ERRDP  ( '#', STEP                               )
         CALL SIGERR ( 'SPICE(INVALIDSTEPSIZE)'                )
         CALL CHKOUT ( 'SPKW08'                                )
         RETURN

      END IF

C
C     Compute the tolerance to use for descriptor time bound checks.
C
      TOL = TOLSCL * MAX( ABS(FIRST), ABS(LAST) )

      IF ( FIRST .LT. EPOCH1 - TOL ) THEN

         CALL SETMSG ( 'The segment descriptor start time # is too '
     .   //            'much less than the beginning time of the  '
     .   //            'segment data # (in seconds past J2000: #). '
     .   //            'The difference is # seconds; the  '
     .   //            'tolerance is # seconds.'                     )
         CALL ETCAL  ( FIRST,  ETSTR                                 )
         CALL ERRCH  ( '#',    ETSTR                                 )
         CALL ETCAL  ( EPOCH1, ETSTR                                 )
         CALL ERRCH  ( '#',    ETSTR                                 )
         CALL ERRDP  ( '#',    FIRST                                 )
         CALL ERRDP  ( '#',    EPOCH1-FIRST                          )
         CALL ERRDP  ( '#',    TOL                                   )
         CALL SIGERR ( 'SPICE(COVERAGEGAP)'                          )
         CALL CHKOUT ( 'SPKW08'                                      )
         RETURN

      END IF

C
C     The end time of the final record must be greater than or
C     equal to the end time of the segment.
C
      LTIME = EPOCH1  +  ( (N-1) * STEP )

      IF ( LAST .GT. LTIME + TOL ) THEN

         CALL SETMSG ( 'The segment descriptor end time # is too '
     .   //            'much greater than the end time of the segment '
     .   //            'data # (in seconds past J2000: #). The '
     .   //            'difference is # seconds; the tolerance is # '
     .   //            'seconds.'                                    )
         CALL ETCAL  ( LAST,  ETSTR                                  )
         CALL ERRCH  ( '#',   ETSTR                                  )
         CALL ETCAL  ( LTIME, ETSTR                                  )
         CALL ERRCH  ( '#',   ETSTR                                  )
         CALL ERRDP  ( '#',   LAST                                   )
         CALL ERRDP  ( '#',   LAST-LTIME                             )
         CALL ERRDP  ( '#',   TOL                                    )
         CALL SIGERR ( 'SPICE(COVERAGEGAP)'                          )
         CALL CHKOUT ( 'SPKW08'                                      )
         RETURN

      END IF

C
C     If we made it this far, we're ready to start writing the segment.
C
C     Store the start and end times to be associated
C     with this segment.
C
      DCD(1) = FIRST
      DCD(2) = LAST

C
C     Create the integer portion of the descriptor.
C
      ICD(1) = BODY
      ICD(2) = CENTER
      ICD(3) = REFCOD
      ICD(4) = DTYPE

C
C     Pack the segment descriptor.
C
      CALL DAFPS ( ND, NI, DCD, ICD, DESCR )

C
C     Begin a new segment.
C
      CALL DAFBNA ( HANDLE, DESCR, SEGID )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'SPKW08' )
         RETURN
      END IF

C
C     The type 8 segment structure is eloquently described by this
C     diagram from the SPK Required Reading:
C
C        +-----------------------+
C        | State 1               |
C        +-----------------------+
C        | State 2               |
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | State N               |
C        +-----------------------+
C        | Epoch of state 1 (ET) |
C        +-----------------------+
C        | Step size             |
C        +-----------------------+
C        | Polynomial degree     |
C        +-----------------------+
C        | Number of states      |
C        +-----------------------+
C
C
      CALL DAFADA ( STATES,          N*STATSZ )
      CALL DAFADA ( EPOCH1,          1        )
      CALL DAFADA ( STEP,            1        )
      CALL DAFADA ( DBLE(DEGREE),    1        )
      CALL DAFADA ( DBLE(N),         1        )

C
C     As long as nothing went wrong, end the segment.
C
      IF ( .NOT. FAILED() ) THEN
         CALL DAFENA
      END IF

      CALL CHKOUT ( 'SPKW08' )
      RETURN
      END