subroutine corrpos(ctimestp,rc)
  include 'globals.h'
  character(len=*) :: rc
  integer :: i,p,k,ctimestp(*)
  real dt2,rcsign,acceff,dt

  if(rc.NE.'sync'.AND.rc.NE.'desync') &
    call terror('unknown sync option in corrpos')
  if(rc.EQ.'sync') then
    if(syncflag.EQ.0) return
    syncflag=0
    rcsign=-1.
    if(verbosity.GT.0) print*,'<corrpos> sync'
  endif
  if(rc.EQ.'desync') then
    if(syncflag.EQ.1) return
    syncflag=1
    rcsign=1.
    if(verbosity.GT.0) print*,'<corrpos> desync'
  endif

  ppropcount=ppropcount+1

  if(.not.periodic) then
    do k=1,ndim
      do i=1,npactive
        p=pactive(i)
        dt2=(dtime/2**(ctimestp(p)-1))**2
        pos(p,k)=pos(p,k)+rcsign*acc(p,k)*dt2/8.
      enddo
    enddo
  else
    do k=1,ndim
      do i=1,npactive
        p=pactive(i)
        dt2=(dtime/2**(ctimestp(p)-1))**2
        pos(p,k)=pos(p,k)+rcsign*acc(p,k)*dt2/8.
        if(pos(p,k).GE.hboxsize) pos(p,k)=pos(p,k)-pboxsize
        if(pos(p,k).LT.-hboxsize) pos(p,k)=pos(p,k)+pboxsize
      enddo
    enddo
  endif
end subroutine

subroutine steppos
  include 'globals.h'
  integer i,ib,p,k,nkeep
  real acceff,distance,csdtime

  ppropcount=ppropcount+1

  if(.not.periodic) then

    do k=1,ndim
      do p=1,nbodies
        pos(p,k)=pos(p,k)+vel(p,k)*tsteppos
      enddo
    enddo
  else
    do k=1,ndim
      do p=1,nbodies
        pos(p,k)=pos(p,k)+vel(p,k)*tsteppos
        if(pos(p,k).GE.hboxsize) pos(p,k)=pos(p,k)-pboxsize
        if(pos(p,k).LT.-hboxsize) pos(p,k)=pos(p,k)+pboxsize
      enddo
    enddo
  endif

  tpos=tpos+tsteppos
  tnow=tpos
end subroutine

subroutine stepvel
  include 'globals.h'
  integer p,k,i
  real acceff,vfac1now,vfac2now,dt,go,maxacc

! adhoc acc limiter
  k=0
  if(usesph) then
    do i=1,nsphact
      p=pactive(i)
      acceff=sqrt(sum(acc(p,1:3)**2))
      maxacc=tstepcrit**2*hsmooth(p)*(2**(itimestp(p)-1)/dtime)**2
      if(acceff.GT.maxacc) then
        k=k+1
        acc(p,1:3)=acc(p,1:3)/acceff*maxacc
      endif
    enddo
  endif
  if(k.GT.0.AND.(verbosity.GT.0).OR.k.GT.0.001*nsph) &
    print*,' > acc limiter',tnow,k
!

  do k=1,ndim
    do i=1,npactive
      p=pactive(i)
      vel(p,k)=vel(p,k)+acc(p,k)*dtime/2**(itimestp(p)-1)
    enddo
  enddo
  do i=1,npactive
    p=pactive(i)
    tvel(p)=tvel(p)+dtime/2**(itimestp(p)-1)
    if(ABS(tvel(p)-tnow).gt.dtime/2**(itimestp(p)-1)) then
      print*,p,tvel(p),tnow,itimestp(p),npactive
      call terror(' stepvel error: tvel mismatch')
    endif
  enddo
end subroutine

subroutine zeroacc
  include 'globals.h'
  acc(pactive(1:npactive),1:3)=0.
end subroutine

subroutine zeropot
  include 'globals.h'
  phi(pactive(1:npactive))=0.
  phiext(pactive(1:npactive))=0.
  if(npactive.EQ.nbodies) esofttot=0.0
end subroutine

subroutine vextrap
  include 'globals.h'
  integer p,k
  do k=1,ndim
    do p=1,nsph
      veltpos(p,k)=vel(p,k)+acc(p,k)*(tnow-tvel(p))
    enddo
  enddo
end subroutine

subroutine allethdot
  include 'globals.h'

  if(.NOT.consph) then
    call terror(' non conservative TBD')
!    if(sph_visc.EQ.'sphv') call omp_ethdotcv(pc)
!    if(sph_visc.EQ.'bulk') call omp_ethdotbv(pc)
!    if(sph_visc.EQ.'sph ') call omp_ethdot(pc)
  else
!    if(sph_visc.EQ.'sph ') call omp_ethdotco(pc)
    if(sph_visc.EQ.'bulk') call terror(' allethdot error')
    if(sph_visc.EQ.'sphv') call terror(' allethdot error')
  endif

end subroutine

subroutine allentdot
  include 'globals.h'

  if(sph_visc.EQ.'sph ') call omp_entdot
  if(sph_visc.EQ.'bulk') call terror(' allentdot error')
  if(sph_visc.EQ.'sphv') call terror(' allentdot error')

end subroutine

subroutine allaccsph
  include 'globals.h'

  if(.NOT.consph) then
    call terror(' non conservative TBD')
!    if(sph_visc.EQ.'sphv') call omp_accsphcv
!    if(sph_visc.EQ.'bulk') call omp_accsphbv
!    if(sph_visc.EQ.'sph ') call omp_accsph
  else
    if(sph_visc.EQ.'sph ') call omp_accsphco
    if(sph_visc.EQ.'bulk') call terror(' allaccsph error')
    if(sph_visc.EQ.'sphv') call terror(' allaccsph error')
  endif

end subroutine

subroutine alldentacc
  include 'globals.h'

  if(.NOT.consph) then
    call terror(' non conservative TBD')
!    if(sph_visc.EQ.'sphv') call omp_accsphcv
!    if(sph_visc.EQ.'bulk') call omp_accsphbv
!    if(sph_visc.EQ.'sph ') call omp_accsph
  else
    if(sph_visc.EQ.'sph ') call omp_entdotaccsphco
    if(sph_visc.EQ.'bulk') call terror(' allaccsph error')
    if(sph_visc.EQ.'sphv') call terror(' allaccsph error')
  endif

end subroutine

subroutine alldethacc
  include 'globals.h'
  if(.NOT.consph) then
    call terror(' dethacc TBD ')
!    if(sph_visc.EQ.'sphv') call omp_accsphcv
!    if(sph_visc.EQ.'bulk') call omp_accsphbv
!    if(sph_visc.EQ.'sph ') call omp_accsph
  else
    if(sph_visc.EQ.'sph ') call omp_ethdotaccsphco
    if(sph_visc.EQ.'bulk') call terror(' allaccsph error')
    if(sph_visc.EQ.'sphv') call terror(' allaccsph error')
  endif

end subroutine

subroutine stepsph
  include 'globals.h'
  integer i,j,npnear,p

  call makesphtree

  if(hupdatemethod.NE.'mass') then
    call terror('TBD: hupdate=mass')
!    call omp_stepnear !change to hsmcal
!    call omp_density  !easychange
!    call veldisp ! lesseasy
  else
    call densnhsmooth
  endif

! call update_reduction !!!!!! not so urgent
! quick fix: (not parallelized)
  call tree_reduction(root,incells,'sph ')

  if(nbh.GT.0) call blackholes
  if(nstar+nbh.GT.0) call mech_feedback

  if(nsphact.EQ.0) return

  if(.NOT.isotherm) then
    if(.NOT.uentropy) then
      call allethdot
      call exstep2(1)
      call alldethacc
      call exstep2(2)
    else
      call allentdot   ! entdot is 2x faster than accsph
      call exstep2(1)
      call alldentacc !  call allentdot
      call exstep2(2)
    endif
      call exstep2(3)
  else
    call alldethacc
  endif

end subroutine

subroutine step
  include 'globals.h'
  integer itime

  itime=0
  do while(itime.LT.2*max_tbin)

    call setrnd()

    if(starform.and.nsph.gt.0) then
      if(verbosity.GT.0) print*,'<stepsys> starform...'
      call newstar
    endif

    if(nbh.gt.0) then
      if(verbosity.GT.0) print*,'<stepsys> bh mergers...'
      call bhmergers
    endif

    if(verbosity.GT.0) print*,'<stepsys> partremoval1...'
    call partremoval

    if(verbosity.GT.0) print*,'<stepsys> timestep..'
    call timestep(itime)

    if(verbosity.GT.0) print*,'<stepsys> steppos..'
    call steppos

! note that particles are not removed in clean, just set to zero mass
! - we have moved this from before partremoval. all routines should be
! 'zero-mass-safe'
    if(verbosity.GT.0) print*,'<stepsys> clean...'
    call clean

!    if(verbosity.GT.0) print*,'<stepsys> cosmo...'

!TBD    if(usesph.and.radiate) call cosmicray

    if(usesph) then
      if(verbosity.GT.0) print*,'<stepsys> extrapolate..'
      call vextrap
      call extrapethrho
    endif

    if(npactive.gt.0) then
      if(verbosity.GT.0) print*,'<stepsys> gravity..'
      call zeroacc
      call gravity('acc ')
    endif

    if((starform.or.radiate)) then
      if(verbosity.GT.0) print*,'<stepsys> starevolv..'
      call starevolv
    endif

    if(usesph.and.nsphact.gt.0.and.radiate) then
      if(verbosity.GT.0) print*,'<stepsys> fuvflux..'
      call zerofuv
      call fuvflux
    endif

    if(usesph.and.radiate) then
      if(verbosity.GT.0) print*,'<stepsys> molecules...'
      call molecules
    endif

    if(usesph) then
      if(verbosity.GT.0) print*,'<stepsys> stepsph..'
      call stepsph
    endif

    if(npactive.GT.0) then
      if(verbosity.GT.0) print*,'<stepsys> stepvel..'
!    if(sphfiltr.and.usesph.and.nsphact.gt.0) call vfilter tbd
      call stepvel
    endif

  enddo

  if(verbosity.GT.0) print*,'<stepsys> partremoval2...'
  call partremoval

  if(verbosity.GT.0) print*,'<stepsys> nbodies,nsph,nstar:',nbodies,nsph,nstar

  if(sortpart) then
    if(verbosity.GT.0) print*,'<stepsys> sorting...'
    if(sortpart) call mortonsort
  endif

end subroutine

subroutine stepsystem(n)
  include 'globals.h'
  integer n
! for AMUSE
! reset the record of the removed ids
    nremovals = 0
! ---
  call step
  print*,'<stepsystem> step completed:',n
  call outstate(n)

end subroutine


c     Subroutine to convert variables
c     AJ_Kettle, 26Feb2019
c     04Jul2019: modified to include all 6 variables
c     14Mar2020: modified for USAF update

      SUBROUTINE convert_variables2(f_ndflag,
     +  l_rgh_datalines,l_data,
     +  s_vec_latitude,s_vec_longitude,s_vec_platformheight,
     +  s_vec_winddirection_deg,s_vec_windspeed_ms,
     +  s_vec_airtemperature_c,s_vec_dewpointtemperature_c,
     +  s_vec_sealevelpressure_hpa,s_vec_stationpressure_hpa,

     +  f_vec_latitude,f_vec_longitude,f_vec_platformheight,
     +  f_vec_winddirection_deg,f_vec_windspeed_ms,
     +  f_vec_airtemperature_c,f_vec_dewpointtemperature_c,
     +  f_vec_sealevelpressure_hpa,f_vec_stationpressure_hpa)

c     +  s_vec_latitude,s_vec_longitude,s_vec_platformheight,
c     +  s_vec_windspeed_ms,
c     +  s_vec_sealevelpressure_hpa,s_vec_stationpressure_hpa,

c     +  f_vec_latitude,f_vec_longitude,f_vec_platformheight,
c     +  f_vec_windspeed_ms,
c     +  f_vec_sealevelpressure_hpa,f_vec_stationpressure_hpa)

      IMPLICIT NONE
c************************************************************************
c     Declare variables passed into program

      INTEGER             :: l_rgh_datalines
      INTEGER             :: l_data

      REAL                :: f_ndflag

      CHARACTER(LEN=*)    :: s_vec_latitude(l_rgh_datalines)
      CHARACTER(LEN=*)    :: s_vec_longitude(l_rgh_datalines)
      CHARACTER(LEN=*)    :: s_vec_platformheight(l_rgh_datalines)
      CHARACTER(LEN=*)    :: s_vec_winddirection_deg(l_rgh_datalines)
      CHARACTER(LEN=*)    :: s_vec_windspeed_ms(l_rgh_datalines)
      CHARACTER(LEN=*)    :: s_vec_airtemperature_c(l_rgh_datalines)
      CHARACTER(LEN=*)   :: s_vec_dewpointtemperature_c(l_rgh_datalines)
      CHARACTER(LEN=*)    :: s_vec_sealevelpressure_hpa(l_rgh_datalines)
      CHARACTER(LEN=*)    :: s_vec_stationpressure_hpa(l_rgh_datalines)

      REAL                :: f_vec_latitude(l_rgh_datalines)
      REAL                :: f_vec_longitude(l_rgh_datalines)
      REAL                :: f_vec_platformheight(l_rgh_datalines)
      REAL                :: f_vec_winddirection_deg(l_rgh_datalines)
      REAL                :: f_vec_windspeed_ms(l_rgh_datalines)
      REAL                :: f_vec_airtemperature_c(l_rgh_datalines)
      REAL               :: f_vec_dewpointtemperature_c(l_rgh_datalines)
      REAL                :: f_vec_sealevelpressure_hpa(l_rgh_datalines)
      REAL                :: f_vec_stationpressure_hpa(l_rgh_datalines)
c*****
c     Variables used within program

      INTEGER             :: i,j,k,ii,jj,kk

      INTEGER             :: i_len

      CHARACTER(LEN=100)  :: s_input
      REAL                :: f_output
      INTEGER             :: i_badflag
c************************************************************************
c      print*,'just inside convert_variables'

c     Do conversions
      DO i=1,l_data
c*****
c      Initialize variables with ndflags
       f_vec_latitude(i)            =f_ndflag
       f_vec_longitude(i)           =f_ndflag
       f_vec_platformheight(i)      =f_ndflag
       f_vec_winddirection_deg(i)   =f_ndflag
       f_vec_windspeed_ms(i)        =f_ndflag
       f_vec_airtemperature_c(i)    =f_ndflag
       f_vec_dewpointtemperature_c(i)=f_ndflag
       f_vec_sealevelpressure_hpa(i)=f_ndflag
       f_vec_stationpressure_hpa(i) =f_ndflag
c*****
c*****
c      Latitude
       s_input=s_vec_latitude(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
         f_vec_latitude(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad latitude',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      Longitude
       s_input=s_vec_longitude(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
         f_vec_longitude(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad longitude',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      Platformheight
       s_input=s_vec_platformheight(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
         f_vec_platformheight(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad platformheight',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      1. Winddirection
       s_input=s_vec_winddirection_deg(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +   f_output,i_badflag)
         f_vec_winddirection_deg(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad winddirection',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      2. Windspeed
       s_input=s_vec_windspeed_ms(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
         f_vec_windspeed_ms(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad windspeed',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      3. Airtemperature
       s_input=s_vec_airtemperature_c(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
         f_vec_airtemperature_c(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad airtemperature',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      4. Dewpointtemperature
       s_input=s_vec_dewpointtemperature_c(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
         f_vec_dewpointtemperature_c(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad dewpointtemperature',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      5. Sealevelpressure
       s_input=s_vec_sealevelpressure_hpa(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
        f_vec_sealevelpressure_hpa(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad sealevelpressure',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****
c      6. Station pressure
       s_input=s_vec_stationpressure_hpa(i)
       i_len=LEN_TRIM(s_input)
       IF (i_len.GT.0) THEN
        CALL convert_single_string_to_float(s_input,f_ndflag,
     +    f_output,i_badflag)
        f_vec_stationpressure_hpa(i)=f_output

        IF (i_badflag.EQ.1) THEN
         print*,'bad stationpressure',s_input
         STOP 'convert_variables'
        ENDIF
       ENDIF
c*****

      ENDDO

c      print*,'just leaving convert_variables'

c      STOP 'convert_variables'

      RETURN
      END


C ra_dpm : calculate depolarization measure and error
C
       implicit    NONE
C
C Include information on standard array sizes etc.
       include '/mrao/include/iolib_constants.inc'
       include '/mrao/include/chrlib_functions.inc'
       include '../include/spec_global.inc'
       include '../include/spec_pars.inc'
C
C Local variables
C   file identifiers
       integer    id_dpm, id_err
       integer    id_hi, id_hmi, id_hdmi
       integer    id_li, id_lmi, id_ldmi
C   scale factors etc.
       real*4     scale_hi, scale_hmi, scale_hdmi
       real*4     scale_li, scale_lmi, scale_ldmi
       real*4     xscale
C   status return
       integer    status
C   number of data points
       integer    ndata
C   array to hold data values
       real*4     x(max_ndata)
       real*4     hi(max_ndata), hmi(max_ndata), hdmi(max_ndata)
       real*4     li(max_ndata), lmi(max_ndata), ldmi(max_ndata)
       real*4     dpm(max_ndata), err(max_ndata)
C   file and directory name(s) and strings
       character  file*(iolen_file)
C   list of columns to operate on
       integer    xc, yc
C   counters
       integer    n

C setup for input
       call io_initio
       call cmd_getiline( 'ra_dpm',define_analysis, status)
C find columns
       call cmd_itemi( 'xc', 1, xc, status )
       call cmd_itemi( 'yc', 1, yc, status )
C find input file names and allocate files
       call cmd_items( 'hi', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id_hi, status)
       call spec_get_data( id_hi, xc, x, ndata, status)
       call spec_get_data( id_hi, yc, hi, ndata, status)
       call cmd_items( 'dpm', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'write', id_dpm, status)
       call spec_hd_copy( id_hi, id_dpm, status )
       call cmd_items( 'err', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'write', id_err, status)
       call spec_hd_copy( id_hi, id_err, status )
       call spec_deallocate(id_hi,status)
       call cmd_items( 'hmi', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id_hmi, status)
       call spec_get_data( id_hmi, yc, hmi, ndata, status)
       call spec_deallocate(id_hmi,status)
       call cmd_items( 'hdmi', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id_hdmi, status)
       call spec_get_data( id_hdmi, yc, hdmi, ndata, status)
       call spec_deallocate(id_hdmi,status)
       call cmd_items( 'li', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id_li, status)
       call spec_get_data( id_li, yc, li, ndata, status)
       call spec_deallocate(id_li,status)
       call cmd_items( 'lmi', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id_lmi, status)
       call spec_get_data( id_lmi, yc, lmi, ndata, status)
       call spec_deallocate(id_lmi,status)
       call cmd_items( 'ldmi', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id_ldmi, status)
       call spec_get_data( id_ldmi, yc, ldmi, ndata, status)
       call spec_deallocate(id_ldmi,status)

C read control data
       call cmd_itemr( 'scale_hi', 1, scale_hi, status )
       call cmd_itemr( 'scale_hmi', 1, scale_hmi, status )
       call cmd_itemr( 'scale_hdmi', 1, scale_hdmi, status )
       call cmd_itemr( 'scale_li', 1, scale_li, status )
       call cmd_itemr( 'scale_lmi', 1, scale_lmi, status )
       call cmd_itemr( 'scale_ldmi', 1, scale_ldmi, status )
       call cmd_itemr( 'xscale', 1, xscale, status )

C scale the input data
       if (status.ne.0) goto 999
       do n=1,ndata
*         print *,n,x(n),hi(n),li(n)
         x(n) = xscale*x(n)
         hi(n) = scale_hi*hi(n)
         hmi(n) = scale_hmi*hmi(n)
         hdmi(n) = scale_hdmi*hdmi(n)
         li(n) = scale_li*li(n)
         lmi(n) = scale_lmi*lmi(n)
         ldmi(n) = scale_ldmi*ldmi(n)
       enddo

C form depolarization measure and error
       do n=1,ndata
         err(n) = 0.0
         dpm(n) = 0.0
         if (hi(n).ne.0.0) then
           hmi(n) = hmi(n)/hi(n)
           hdmi(n) = hdmi(n)/hi(n)
           if (li(n).ne.0.0) then
             lmi(n) = lmi(n)/li(n)
             ldmi(n) = ldmi(n)/li(n)
             err(n) = (hdmi(n)+ldmi(n))/(hmi(n)+lmi(n))
             dpm(n) = (hmi(n)-lmi(n))/(hmi(n)+lmi(n))
           endif
         endif
       enddo

C deallocate files
       call spec_put_data( id_dpm, 1, x, ndata, status)
       call spec_put_data( id_dpm, 2, dpm, ndata, status)
       call spec_put_data( id_err, 1, x, ndata, status)
       call spec_put_data( id_err, 2, err, ndata, status)
       call spec_hd_set( id_dpm, 'ncols', '2', status)
       call spec_hd_set( id_err, 'ncols', '2', status)
999    continue
       call spec_deallocate( id_dpm, status )
       call spec_deallocate( id_err, status )

       end


      SUBROUTINE RESTMOD
C
C CHANGE RECORD
C **  SUBROUTINE RESTOUT WRITES A RESTART FILE
C
      USE GLOBAL

      DIMENSION LIJMOD(100)

      OPEN(99,FILE='RESTART.OUT',STATUS='UNKNOWN')
      CLOSE(99,STATUS='DELETE')
      OPEN(99,FILE='RESTART.OUT',STATUS='UNKNOWN')
      IF(ISDYNSTP.EQ.0)THEN
        TIME=DT*FLOAT(N)+TCON*TBEGIN
        TIME=TIME/TCON
      ELSE
        TIME=TIMESEC/TCON
      ENDIF
      WRITE(99,909)N,TIME
      PRINT *,'READING RESTART FILE: RESTMOD.INP'
      OPEN(1,FILE='RESTMOD.INP',STATUS='UNKNOWN')
      READ(1,*)NIJMOD
      DO NNIJ=1,NIJMOD
        READ(1,*)ITMP,JTMP
        LIJMOD(NNIJ)=LIJ(ITMP,JTMP)
      ENDDO
      CLOSE(1)
      DO L=2,LA
        LSMOD=1
        DO NNIJ=1,NIJMOD
          IF(L.EQ.LIJMOD(NNIJ)) LSMOD=0
        ENDDO
        IF(LSMOD.EQ.1)THEN
          WRITE(99,906)HP(L),H1P(L),HWQ(L),H2WQ(L),BELV(L)
          WRITE(99,907)UHDYE(L),UHDY1E(L),VHDXE(L),VHDX1E(L)
          WRITE(99,907)(U(L,K),K=1,KC)
          WRITE(99,907)(U1(L,K),K=1,KC)
          WRITE(99,907)(V(L,K),K=1,KC)
          WRITE(99,907)(V1(L,K),K=1,KC)
          WRITE(99,907)(QQ(L,K),K=0,KC)
          WRITE(99,907)(QQ1(L,K),K=0,KC)
          WRITE(99,907)(QQL(L,K),K=0,KC)
          WRITE(99,907)(QQL1(L,K),K=0,KC)
          WRITE(99,907)(DML(L,K),K=0,KC)
          IF(ISCO(1).EQ.1)THEN
            WRITE(99,907)(SAL(L,K),K=1,KC)
            WRITE(99,907)(SAL1(L,K),K=1,KC)
          ENDIF
          IF(ISCO(2).EQ.1)THEN
            WRITE(99,907)(TEM(L,K),K=1,KC)
            WRITE(99,907)(TEM1(L,K),K=1,KC)
          ENDIF
          IF(ISCO(3).EQ.1)THEN
            WRITE(99,907)(DYE(L,K),K=1,KC)
            WRITE(99,907)(DYE1(L,K),K=1,KC)
          ENDIF
          IF(ISCO(4).EQ.1)THEN
            WRITE(99,907)SEDB(L,1,1),(SED(L,K,1),K=1,KC)
            WRITE(99,907)SEDB1(L,1,1),(SED1(L,K,1),K=1,KC)
          ENDIF
          IF(ISCO(5).EQ.1)THEN
            WRITE(99,907)(SFL(L,K),K=1,KC)
            WRITE(99,907)(SFL2(L,K),K=1,KC)
          ENDIF
        ENDIF
      ENDDO
      DO M=1,5
        IF(ISCO(M).EQ.1)THEN
          DO LL=1,NCBS
            DO K=1,KC
              NLOS(LL,K,M)=NLOS(LL,K,M)-N
            ENDDO
            WRITE(99,908)(NLOS(LL,K,M),K=1,KC)
            WRITE(99,907)(CLOS(LL,K,M),K=1,KC)
          ENDDO
          DO LL=1,NCBW
            DO K=1,KC
              NLOW(LL,K,M)=NLOW(LL,K,M)-N
            ENDDO
            WRITE(99,908)(NLOW(LL,K,M),K=1,KC)
            WRITE(99,907)(CLOW(LL,K,M),K=1,KC)
          ENDDO
          DO LL=1,NCBE
            DO K=1,KC
              NLOE(LL,K,M)=NLOE(LL,K,M)-N
            ENDDO
            WRITE(99,908)(NLOE(LL,K,M),K=1,KC)
            WRITE(99,907)(CLOE(LL,K,M),K=1,KC)
          ENDDO
          DO LL=1,NCBN
            DO K=1,KC
              NLON(LL,K,M)=NLON(LL,K,M)-N
            ENDDO
            WRITE(99,908)(NLON(LL,K,M),K=1,KC)
            WRITE(99,907)(CLON(LL,K,M),K=1,KC)
          ENDDO
        ENDIF
      ENDDO
      CLOSE(99)
  906 FORMAT(5E17.8)
  907 FORMAT(13E17.8)
  908 FORMAT(12I10)
  909 FORMAT(I20,4X,F12.4)
      RETURN
      END


      Subroutine Isles(Vertex,ProbCuth,ProbCute,Ierr)
*
*
* This routine performs CAL clustering by matching cell Islands
* based on angular separation. The Cell Islands are found for each
* CAL separately (F,R,B), and separately for each section (EMC,HAC1,HAC2)
* using the cell Islands routine developed by Gennady Briskin.  (The original
* Island algorithm was developed by Larry Wai.)  A probability is assigned
* based on the 3-D angular separation from on a parametrization derived
* from a single-pion MC.
*
* USER INPUT:  Vertex(3) -- Reconstructed vertex(1=x,2=y,3=z)
*
*              ProbCuth  -- probability cut for matching HAC2 -> HAC1
*                                                    and HAC1 -> EMC
*                           recommended value is 0.01 for general purpose,
*                           but can be looser in clean events (e.g., VM)
*
*              ProbCute  -- probability cut for matching EMC -> EMC
*                           recommended value is 1.0 (no matching allowed)
*                           for electrons, 0.02 for hadrons
*                           but can be looser in clean events (e.g., VM)
*
* OUTPUT:      Ierr    0 -- Everything is fine
*                      1 -- No CAL information (zCells=0)
*
* +CDE, ZIsles:
*
*  Isles Input:
*
*===>  COMMON /zIsl01/ HAS TO BE FILLED BY USER BEFORE CALLING ISLES ROUTINE
*
*      COMMON /zIsl01/
*      zCells              -- Number of cells to be considered for clustering.
*      zPnrl(   1:Nr_cMax) -- PoserNr   of the cell
*      zEl(     1:Nr_cMax) -- Energy    of the cell
*      zImbl(   1:Nr_cMax) -- Imbalance of the cell
*      zT1(     1:Nr_cMax) -- time(1)   of the cell
*      zT2(     1:Nr_cMax) -- time(2)   of the cell
*      zID(     1:Nr_cMax) -- Row number in table Caltru(i.e. Caltru_ID)
*
*  Isles Output:
*
*      COMMON /zIsl02/
*
*      COMMON /zIsl03/
*
*      COMMON /zIsl04/
*      I_caltru(1:Nr_cMax) -- cluster assignment for each cell in
*                             COMMON /zIsl01/
*
*
* A. Caldwell 22/4/96
*
* -- modified --
* G. Briskin 24/10/97
*
******************************************************************************
*
      Implicit NONE
*
#include "zisles.inc"
!  /*       <-- Islands information  */
*
*==>  Input Variables
      Real    Vertex(3)
      Real    ProbCuth,ProbCute

*==>  Output
      Integer Ierr

*------------------------------
*     Internal Variables      *
*------------------------------

*==>  Counter for coneIslands
      Integer nclus

*==>  Some Usefull Constants
      REAL       Pi, TwoPi, PiBy2
      PARAMETER (Pi = 3.14159265358979323846)
      PARAMETER (TwoPi = 2.*Pi)
      PARAMETER (PiBy2 = Pi/2.0)
      Real       todeg
      Parameter (todeg = 180./Pi)

*==>  Error flags
      Logical Lerr

*==>  Counters
      Integer Icell,no_I,n,m,l,I,K
      Integer kIsl,NrCells

*==>  Position recon variables
      Real    xC,yC,zC
      Real    dx, Er, El, d1, d2(2), wi, wtot

*==>  Isles variables
      Integer NEMC,NHAC1,NHAC2

      Real    E_EMC(   nI_Max),theta(    nI_Max),phi(      nI_Max)
      Real    E_HAC1(  nI_Max),theta1(   nI_Max),phi1(     nI_Max)
      Real    E_HAC2(  nI_Max),theta2(   nI_Max),phi2(     nI_Max)

      Integer EMCtoIsl(nI_Max),H1toIsl(  nI_Max),H2toIsl(  nI_Max)
      Integer match(   nI_Max),match1(   nI_Max),match2(   nI_Max)
      Integer nassign( nI_Max),nassignh1(nI_Max),nassignh2(nI_Max)
      Integer IND(     nI_Max)

*==>  Auxilary variables for angle determination
      Real    r,z_e

      Real    probmin,dphi12,dcos,dist,prob
      Real    probisles

*==>  Useful variables
      Integer CellNr,i_CAL,i_MOD,i_TOW,i_Typ

*==>  Variables for projection on perpendicular plane
      Real    rayX,rayY,rayZ
      Real    lenC,unit_Cx,unit_Cy,unit_Cz
      Real    rhoX,rhoY,rhoZ
      Real    Swim

*==>  Function Declarations
      Integer get_fbr, get_mod, get_tow, get_typ

      get_fbr(CellNr) = ISHFT(CellNr,-14)+1
      get_Mod(CellNr) = ISHFT(IAND(CellNr,x'3E00'),-9)+1
      get_Tow(CellNr) = ISHFT(IAND(CellNr,x'1F0' ),-4)+1
      get_typ(CellNr) = ISHFT(IAND(CellNr,x'E'   ),-1)

*==>  Zero Ground
      Ierr  = 0
      nIsl  = 0
      Nclus = 0

*==>  Check that we dont have too many or too few cells
      If (zCells.LE.0) then
       Ierr = 1
       Return
      Endif

*==> Use cellIslands routine from Gennady to get Islands
*    (mode 11=corner cells connect ,12=corner cells DONT connect)

      NEMC  = 0
      NHAC1 = 0
      NHAC2 = 0

      call z_cIsles(Vertex,zCells,zEl,zPnrl,zImbl,no_I,zcIsl_Mode,Ierr)
      If (Ierr.LT.0) then
       Write(6,*)'*==> Isles: Error from z_cIsles',Ierr
       Ierr = 2
       Return
      Endif

*==>  Get theta and phi of cellIslands
      Do kIsl=1,no_I

       If    (IslTyp(kIsl).EQ.1000) Then

        NEMC           = NEMC + 1

*==>    Store Island number +1000 for Caltru row number
        NrCells = NrcIsl(kIsl)
        Do I=1,NrCells
         l = zIsl_Cell(I,kIsl)
         I_Caltru(l)=NEMC+1000
        EndDo

        EMCtoIsl(NEMC) = kIsl
        E_EMC( NEMC)   = eIsl(kIsl)
        z_e            = zIsl(kIsl)-Vertex(3)
        r              = SQRT(yIsl(kIsl)**2+xIsl(kIsl)**2)
        theta( NEMC)   = ATAN2(r,z_e)
        phi(   NEMC)   = ATAN2(yIsl(kIsl),xIsl(kIsl))
        If(phi(NEMC).LT.0) phi(NEMC) = phi(NEMC) + TwoPi

        If (Isles_Debug) Then
         Print *,'*--> EMC Island ',kIsl,eIsl(kIsl),NrcIsl(kIsl),
     &        xIsl(kIsl),yIsl(kIsl),zIsl(kIsl)
         NrCells = NrcIsl(kIsl)
         Do I=1,NrCells
          CellNr = pCellIsl(I,kIsl)
          i_CAL = get_fbr(CellNr)
          i_MOD = get_mod(CellNr)
          i_TOW = get_tow(CellNr)
          i_Typ = get_typ(CellNr)
          Print *,'*-> Cell,CAL,MOD,TOW,Type',
     &         CellNr,i_CAL,i_MOD,i_TOW,i_Typ
         EndDo
        EndIf

       ElseIf(IslTyp(kIsl).EQ.2000) Then

        NHAC1          = NHAC1 + 1

*==>    Store Island number +2000 for Caltru row number
        NrCells = NrcIsl(kIsl)
        Do I=1,NrCells
         l = zIsl_Cell(I,kIsl)
         I_Caltru(l)=NHAC1+2000
        EndDo

        H1toIsl(NHAC1) = kIsl
        E_HAC1( NHAC1) = eIsl(kIsl)
        z_e            = zIsl(kIsl)-Vertex(3)
        r              = SQRT(yIsl(kIsl)**2+xIsl(kIsl)**2)
        theta1( NHAC1) = ATAN2(r,z_e)
        phi1(   NHAC1) = ATAN2(yIsl(kIsl),xIsl(kIsl))
        If(phi1(NHAC1).LT.0) phi1(NHAC1) = phi1(NHAC1) + TwoPi

        If (Isles_Debug) Then
         Print *,'*--> HAC1 Island ',kIsl,eIsl(kIsl),NrcIsl(kIsl),
     &        xIsl(kIsl),yIsl(kIsl),zIsl(kIsl)
         NrCells = NrcIsl(kIsl)
         Do I=1,NrCells
          CellNr = pCellIsl(I,kIsl)
          i_CAL = get_fbr(CellNr)
          i_MOD = get_mod(CellNr)
          i_TOW = get_tow(CellNr)
          i_Typ = get_typ(CellNr)
          Print *,'*-> Cell,CAL,MOD,TOW,Type',I,i_CAL,i_MOD,i_TOW,i_Typ
         EndDo
        EndIf

       ElseIf(IslTyp(kIsl).EQ.3000) Then

        NHAC2          = NHAC2 + 1

*==>    Store Island number +3000 for Caltru row number
        NrCells = NrcIsl(kIsl)
        Do I=1,NrCells
         l = zIsl_Cell(I,kIsl)
         I_Caltru(l)=NHAC2+3000
        EndDo

        H2toIsl(NHAC2) = kIsl
        E_HAC2( NHAC2) = eIsl(kIsl)
        z_e            = zIsl(kIsl) - Vertex(3)
        r              = SQRT(yIsl(kIsl)**2+xIsl(kIsl)**2)
        theta2( NHAC2) = ATAN2(r,z_e)
        phi2(   NHAC2) = ATAN2(yIsl(kIsl),xIsl(kIsl))
        If(phi2(NHAC2).LT.0) phi2(NHAC2) = phi2(NHAC2) + TwoPi

        If (Isles_Debug) Then
         Print *,'*--> HAC2 Island ',kIsl,eIsl(kIsl),NrcIsl(kIsl),
     &   xIsl(kIsl),yIsl(kIsl),zIsl(kIsl)
         NrCells = NrcIsl(kIsl)
         Do I=1,NrCells
          CellNr = pCellIsl(I,kIsl)
          i_CAL = get_fbr(CellNr)
          i_MOD = get_mod(CellNr)
          i_TOW = get_tow(CellNr)
          i_Typ = get_typ(CellNr)
          Print *,'*-> Cell,CAL,MOD,TOW,Type',I,i_CAL,i_MOD,i_TOW,i_Typ
         EndDo
        EndIf

       Else
        Print *,'*-> Unknown Island Type ???',kIsl,IslTyp(kIsl)
        STOP
       EndIf

      Enddo

************************************************************************
*  Lets do the matching
*
*  We start from hac2 and work our way inwards to the EMC.  Every EMC
* Island will be a seed for a 'super'-Island.  I.e., there is initially
* no grouping of EMC Islands.  EMCs can be matched if they are close
* together depending on user supplied probability cut.
*
*  Get distances between clusters in theta-phi space and take the highest
* probability match.  It has to be larger than the user supplied cut.
*************************************************************************

*
*==>  Start with HAC2
      Do n=1,nhac2
       match2(n) = 0
       probmin   = probcuth
*
*==>   Check for HAC1 within angular cone
       Do m=1,nhac1
        dphi12 = phi2(n)-phi1(m)
        dcos   = sin(theta2(n))*sin(theta1(m))*cos(dphi12)+
     &           cos(theta2(n))*cos(theta1(m))
        dist   = acos(dcos)

*==>    Get probability for this angular separation
        prob   = probisles(dist,2)

*==>    Keep highest probability match above cut
        If (prob.gt.probmin) then
         probmin   = prob
         match2(n) = m

         If (Isles_Debug) Then
          Print *,'*'
          Print *,'*'
          Print *,'*-> HAC2',n,' ->HAC1',m,' Prob',prob
          kIsl = H2toIsl(n)
          NrCells = NrcIsl(kIsl)
          Print *,'*'
          Print *,'*-> HAC2 Island: ',theta2(n)*todeg,phi2(n)*todeg
          Do I=1,NrCells
           CellNr = pCellIsl(I,kIsl)
           i_CAL = get_fbr(CellNr)
           i_MOD = get_mod(CellNr)
           i_TOW = get_tow(CellNr)
           i_Typ = get_typ(CellNr)
           Print *,'*-> Cell,CAL,MOD,TOW,Type',I,i_CAL,i_MOD,i_TOW,i_Typ
          EndDo
*
          kIsl = H1toIsl(m)
          NrCells = NrcIsl(kIsl)
          Print *,'*'
          Print *,'*-> HAC1 Island',theta2(m)*todeg,phi1(m)*todeg
          Do I=1,NrCells
           CellNr = pCellIsl(I,kIsl)
           i_CAL = get_fbr(CellNr)
           i_MOD = get_mod(CellNr)
           i_TOW = get_tow(CellNr)
           i_Typ = get_typ(CellNr)
           Print *,'*-> Cell,CAL,MOD,TOW,Type',I,i_CAL,i_MOD,i_TOW,i_Typ
          EndDo
         EndIf

        Endif
       EndDo
*
*==>  If there's no link to a HAC1, try a direct link to an EMC
       Do m=1,nemc
        dphi12 = phi2(n)-phi(m)
        dcos   = sin(theta2(n))*sin(theta(m))*cos(dphi12)+
     &           cos(theta2(n))*cos(theta(m))
        dist   = acos(dcos)
        prob   = probisles(dist,1)

*==>    Keep highest probability match above cut
        If (prob.gt.probmin) then
         probmin=prob
         match2(n) = m+1000

         If (Isles_Debug)
     &        print *,'hac2 -> EMC link',n,' emc',m,' prob',prob

        Endif
       EndDo
      EndDo
*
*==>  Now link the hac1 to emc
      Do n=1,nhac1
       probmin=probcuth
       match1(n)=0
       Do m=1,nemc
        dphi12 = phi1(n)-phi(m)
        dcos=sin(theta1(n))*sin(theta(m))*cos(dphi12)+
     &       cos(theta1(n))*cos(theta(m))
        dist=acos(dcos)
        prob = probisles(dist,1)
        If (prob.gt.probmin) then
         probmin=prob
         match1(n) = m

         If (Isles_Debug) Then
          Print *,'*'
          Print *,'*'
          Print *,'*-> HAC1',n,' ->EMC',m,' Prob',prob
          kIsl = H1toIsl(n)
          NrCells = NrcIsl(kIsl)
          Print *,'*'
          Print *,'*-> HAC1 Island: ',theta1(n)*todeg,phi1(n)*todeg
          Do I=1,NrCells
           CellNr = pCellIsl(I,kIsl)
           i_CAL = get_fbr(CellNr)
           i_MOD = get_mod(CellNr)
           i_TOW = get_tow(CellNr)
           i_Typ = get_typ(CellNr)
           Print *,'*-> Cell,CAL,MOD,TOW,Type',I,i_CAL,i_MOD,i_TOW,i_Typ
          EndDo
*
          kIsl = EMCtoIsl(m)
          NrCells = NrcIsl(kIsl)
          Print *,'*'
          Print *,'*-> EMC Island',theta(m)*todeg,phi(m)*todeg
          Do I=1,NrCells
           CellNr = pCellIsl(I,kIsl)
           i_CAL = get_fbr(CellNr)
           i_MOD = get_mod(CellNr)
           i_TOW = get_tow(CellNr)
           i_Typ = get_typ(CellNr)
           Print *,'*-> Cell,CAL,MOD,TOW,Type',I,i_CAL,i_MOD,i_TOW,i_Typ
          EndDo
         EndIf

        Endif
       enddo
      enddo
*
*  Now link the emc to emc
*
*  First sort in energy (ascending energy)
*
      CALL SORTZV(E_EMC,IND,nemc,1,0,0)
*
      do n=1,nemc
*
*  Different probability requirement for matching EMC's
*
       probmin=probcute
       match(IND(n))=0
       do m=n+1,nemc
        dphi12 = phi(IND(n))-phi(IND(m))
        dcos=sin(theta(IND(n)))*sin(theta(IND(m)))*cos(dphi12)+
     &       cos(theta(IND(n)))*cos(theta(IND(m)))
        dist=acos(dcos)
        prob = probisles(dist,1)
        If (prob.gt.probmin) then
         probmin=prob
         match(IND(n)) = IND(m)

         If (Isles_Debug) Then
          Print *,'*'
          Print *,'*'
          Print *,'*-> EMC',IND(n),' -->EMC',IND(m),' prob',prob
          kIsl = EMCtoIsl(n)
          NrCells = NrcIsl(kIsl)
          Print *,'*'
          Print *,'*-> EMC Island: ',IND(n),theta(n)*todeg,phi(n)*todeg
          Do I=1,NrCells
           CellNr = pCellIsl(I,kIsl)
           i_CAL = get_fbr(CellNr)
           i_MOD = get_mod(CellNr)
           i_TOW = get_tow(CellNr)
           i_Typ = get_typ(CellNr)
           Print *,'*-> Cell,CAL,MOD,TOW,Type',
     &          CellNr,i_CAL,i_MOD,i_TOW,i_Typ
          EndDo
*
          kIsl = EMCtoIsl(m)
          NrCells = NrcIsl(kIsl)
          Print *,'*'
          Print *,'*-> EMC Island: ',IND(m),theta(m)*todeg,phi(m)*todeg
          Do I=1,NrCells
           CellNr = pCellIsl(I,kIsl)
           i_CAL = get_fbr(CellNr)
           i_MOD = get_mod(CellNr)
           i_TOW = get_tow(CellNr)
           i_Typ = get_typ(CellNr)
           Print *,'*-> Cell,CAL,MOD,TOW,Type',
     &          CellNr,i_CAL,i_MOD,i_TOW,i_Typ
          EndDo
         EndIf

        Endif
       enddo
      enddo

*********************************************************************
* Now we update the cluster information
* We assign a cluster number to each CALTRU row.
*********************************************************************
*
* Zero the cluster assignment array for HAC2
*
      Do n=1,nhac2
       nassignh2(n) = 0
      Enddo
*
*  First assign the HAC2 cluster numbers to HAC1s
*
* Loop over caltru rows
      Do n=1,zCells
* Check is HAC2
       If (I_caltru(n).ge.3000) then
* If so, get cluster index
        m=I_caltru(n)-3000
* Check if this HAC2 island is matched to a HAC1 island
        If (match2(m).gt.0.and.match2(m).lt.1000) then
* If so, then point this caltru row to the HAC1 cluster
         I_caltru(n) = 2000+match2(m)
* Check if this HAC2 island is matched to an EMC island
        ElseIf (match2(m).gt.1000) then
* If so, then point this caltru row to the EMC cluster
         I_caltru(n) = match2(m)
        Else
* If not, its a standalone cluster
* Check if this cluster has a cluster number
         If (nassignh2(m).eq.0) then
* No, so give it one
          nclus = nclus + 1
          nassignh2(m) = nclus
         Endif
         I_caltru(n) = nassignh2(m)
        Endif
       Endif
      Enddo
*
*  Now HAC1s to EMCs
*
* Zero the cluster assignment array for HAC1
*
      Do n=1,nhac1
       nassignh1(n) = 0
      Enddo
*
      Do n=1,zCells
       If (I_caltru(n).ge.2000) then
        m=I_caltru(n)-2000
        If (match1(m).gt.0) then
         I_caltru(n) = 1000+match1(m)
        Else
* Check if this cluster has a cluster number
         If (nassignh1(m).eq.0) then
* No, so give it one
          nclus = nclus + 1
          nassignh1(m) = nclus
         Endif
         I_caltru(n) = nassignh1(m)
        Endif
       Endif
      Enddo
*
*  Now EMCs to EMCs -- note that their could be a chain n -> m -> k ...
*
      Do n=1,zCells
C	 print *,I_caltru(n)
       If (I_caltru(n).ge.1000) then
 19     m=I_caltru(n)-1000
C     Print *,m,match(m)
        If (match(m).gt.0) then
         I_caltru(n) = 1000+match(m)
        Else
         goto 20
        Endif
        goto 19
       Endif
 20    continue
      Enddo
*
* Zero the cluster assignment array
*
      Do n=1,nI_Max
       nassign(n) = 0
      Enddo
*
      Do n=1,zCells
       If (I_caltru(n).ge.1000) then
        m = I_caltru(n) - 1000
* Check if this cluster has a cluster number
        If (nassign(m).eq.0) then
*     No, so give it one
         nclus = nclus + 1
         nassign(m) = Nclus
        Endif
        I_caltru(n) = nassign(m)
       Endif
      Enddo

*==>  How many coneIslands did we find :-)
      nIsl = Nclus

**********************************************************************
*  We're done - now for some bookkeeping
**********************************************************************

*
* We now loop over the CALTRU cells and fill Gennady's arrays
*
      Do n=1,nI_Max
       eIsl(   n) = 0.
       xIsl(   n) = 0.
       yIsl(   n) = 0.
       zIsl(   n) = 0.
       rIsl(   n) = 0.
       xI1(    n) = 0.
       yI1(    n) = 0.
       zI1(    n) = 0.
       emcEIsl(n) = 0.
       NrcIsl( n) = 0
      Enddo
*
      Do Icell=1,zCells
       kIsl = I_caltru(Icell)
       If (kIsl.GT.0.AND.kIsl.LE.nIsl) Then

        NrcIsl(                 kIsl) = NrcIsl(kIsl) + 1
*
        zIsl_Cell( NrcIsl(kIsl),kIsl) =       Icell
*
        ECellIsl(  NrcIsl(kIsl),kIsl) = zEl(  Icell)
        ImbCellIsl(NrcIsl(kIsl),kIsl) = zImbl(Icell)
        pCellIsl(  NrcIsl(kIsl),kIsl) = zPnrl(Icell)
        eIsl(                   kIsl) = eIsl(kIsl) + zEl(Icell)
*
        If (Isles_Debug) Then
         CellNr= zPnrl(Icell)
         i_CAL = get_fbr(CellNr)
         i_MOD = get_mod(CellNr)
         i_TOW = get_tow(CellNr)
         i_Typ = get_typ(CellNr)
         Print *,'*-> Cell #',CellNr,'  Assigned to cluster ',kIsl
         Print *,'*-> CAL,MOD,TOW,Type',i_CAL,i_MOD,i_TOW,i_Typ
        Endif

       Else
        Write(6,*),'Isles: wrong # Isls ',kIsl,zCells,NEMC,NHAC1,NHAC2
        STOP
       Endif
      Enddo
*
*-->  get Island position
*
      Do kIsl=1,nIsl
*
       NrCells = NrcIsl(kIsl)
       wtot    = 0

*-->  Improve x-pos of cell by left-right info
*     and use log weighted position recon
       Do I=1,NrCells

        CellNr = pCellIsl(I,kIsl)
        i_Typ  = get_typ(CellNr)
*
        Call cccXYZ(CellNr,xC,yC,zC,Lerr)
*
        xI1(kIsl) = xI1(kIsl) + ECellIsl(I,kIsl)*xC
        yI1(kIsl) = yI1(kIsl) + ECellIsl(I,kIsl)*yC
        zI1(kIsl) = zI1(kIsl) + ECellIsl(I,kIsl)*zC
*
        If (i_Typ.LE.5) emcEIsl(kIsl) = emcEIsl(kIsl) + ECellIsl(I,kIsl)

* N.T. 3/99 'max(0,...' --> max(0.,...'
        If (i_Typ.LE.4) then
         wi  = max(0.,4.+log(ECellIsl(I,kIsl)/eIsl(kIsl)))
        Else
         wi  = max(0.,2.+log(ECellIsl(I,kIsl)/eIsl(kIsl)))
        End if
        wtot = wtot + wi
*
        Er  = (ECellIsl(I,kIsl)+ImbCellIsl(I,kIsl))/2.0
        El  = (ECellIsl(I,kIsl)-ImbCellIsl(I,kIsl))/2.0
*
        If (Er.LT.0.0) Er = 0.0
        If (El.LT.0.0) El = 0.0
        If (El.EQ.0.0) dx = 10.
        If (Er.EQ.0.0) dx = -10.
        If (Er.NE.0.0.AND.El.NE.0.0) dx = 54./2.*log(Er/El)
        If (Abs(dx).GT.10.0 ) dx = sign(10.0,dx)

************************************************************
*     Bug fix:
*
*     used POSER Nr to identify F/B/RCAL
*     this is not sensitive to shifts in the CAL position
*
*     19.5.2000 by F.Goebel
*
*       If (zC.GE.234. .OR. zC.LE.-150.) Then
*************************************************************
        if (get_fbr(CellNr).ne.2) then
*-->      FCAL or RCAL case
         xC      = xC + dx
         xIsl(kIsl) = xIsl(kIsl) + wi*xC
         yIsl(kIsl) = yIsl(kIsl) + wi*yC
         zIsl(kIsl) = zIsl(kIsl) + wi*zC
        Else
*-->      BCAL case
         d1         = Sqrt(xC**2+yC**2)
         d2(1)      = -yC/d1
         d2(2)      =  xC/d1
         xC         =  xC + dx*d2(1)
         yC         =  yC + dx*d2(2)
         xIsl(kIsl) = xIsl(kIsl) + wi*xC
         yIsl(kIsl) = yIsl(kIsl) + wi*yC
         zIsl(kIsl) = zIsl(kIsl) + wi*zC
        EndIf
       EndDo
*
       xI1(kIsl) = xI1(kIsl)/eIsl(kIsl)
       yI1(kIsl) = yI1(kIsl)/eIsl(kIsl)
       zI1(kIsl) = zI1(kIsl)/eIsl(kIsl)
*
       If (wtot.GT.0) Then
        xIsl(kIsl) = xIsl(kIsl)/wtot
        yIsl(kIsl) = yIsl(kIsl)/wtot
        zIsl(kIsl) = zIsl(kIsl)/wtot
       Else
        xIsl(kIsl) = xI1(kIsl)
        yIsl(kIsl) = yI1(kIsl)
        zIsl(kIsl) = zI1(kIsl)
       EndIf
*
*-->  Find Maximum Radius of the Island on the plane perpendicular
*     to Island Ray from Vertex
       rayX = xIsl(kIsl)
       rayY = yIsl(kIsl)
       rayZ = zIsl(kIsl)-Vertex(3)

       Do I=1,NrCells

        CellNr = pCellIsl(I,kIsl)
        Call cccXYZ(CellNr,xC,yC,zC,Lerr)
        zC         = zC-Vertex(3)
*
        lenC       = Sqrt(xC**2+yC**2+zC**2)
        unit_Cx    = xC/lenC
        unit_Cy    = yC/lenC
        unit_Cz    = zC/lenC
*
        Swim       = (rayX**2+rayY**2+rayZ**2)/
     &               (unit_Cx*rayX+unit_Cy*rayY+unit_Cz*rayZ)
*
        rhoX       = Swim*unit_Cx - rayX
        rhoY       = Swim*unit_Cy - rayY
        rhoZ       = Swim*unit_Cz - rayZ
        rIsl(kIsl) = max(rIsl(kIsl),Sqrt(rhoX**2+rhoY**2+rhoZ**2))

       EndDo

      EndDo
*
**-->> oooooooh goody we made to the end :-)
*
      Return
      End

      Real Function probisles(dist,Itype)
*
*  Calculate the probablity that clusters should match for angle
* difference dist.  The matching for H1<->H2 is specified by itype=2
* while EMC<->H1 is specified by itype=1.
*
*  The data needed for the matching cuts
*
      Implicit none
*
      Integer Itype
      Real ph21(4),ph1e(4),dist,slope
      Data ph21/6.527,103.7,-483.2,643.6/
      Data ph1e/11.75,100.1,-509.2,650.5/
*
*  Get probability for EMC<->HAC1
*
      If (Itype.eq.1) then
       slope = ph1e(1)+ph1e(2)*dist+ph1e(3)*dist**2+ph1e(4)*dist**3
       probisles = exp(-slope*dist)
*
*  and now HAC1<->HAC2
*
      Elseif (Itype.eq.2) then
       slope = ph21(1)+ph21(2)*dist+ph21(3)*dist**2+ph21(4)*dist**3
       probisles = exp(-slope*dist)
      Else
       probisles = 0.
      Endif
*
      Return
      End


subroutine calctends_no_ad(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    calctends_ad         adjoint of calctends_tl
!   prgmmr: kleist           org: np20                date: 2005-09-29
!
! abstract: adjoint of routine that compute tendencies for u,v,Tv,prs
!
! program history log:
!   2005-09-29  kleist
!   2005-10-17  kleist - changes to improve computational efficiency
!   2005-11-21  kleist - add tracer tendencies, use new module
!   2006-01-31  kleist - add indices to sum* variables being initialized in loop
!   2006-04-12  treadon - replace sigi with bk5
!   2006-04-21  kleist - add divergence tendency bits
!   2006-07-31  kleist - changes to use ps instead of ln(ps)
!   2006-09-21  kleist - add rescaling to divergence tendency formulation
!   2007-03-13  kleist - move jcrescale_ad (and related code) into if (divtflg) block
!   2007-04-16  kleist - move constraint specific items elsewhere
!   2007-05-08  kleist - add bits for fully generalized vertical coordinate
!   2007-06-21  rancic - add pbl
!   2007-07-26  cucurull - add 3d pressure pri in argument list;
!                          move getprs_ad outside calctends_ad;
!                          call getprs_horiz_ad; remove ps from argument
!                          list
!   2007-08-08  derber - optimize
!   2008-06-05  safford - rm unused var "nnn" and unused uses
!   2009-04-21  derber - remove call to getstvp and modify get_derivatives to include uv
!   2009-08-20  parrish - replace curvfct with curvx, curvy.  this allows tendency computation to
!                          work for any general orthogonal coordinate.
!   2010-11-03  derber - moved threading calculations to gridmod and modified
!   2012-02-08  kleist - add uvflag to argument list.
!   2013-01-23  parrish - change t_t from intent(in) to intent(inout) (flagged by WCOSS intel debug compile)
!   2013-10-19  todling - derivatives and guess fields now in bundles
!
! usage:
!   input argument list:
!     u        - zonal wind on subdomain
!     v        - meridional wind on subdomain
!     t        - virtual temperature on subdomain
!     u_t      - time tendency of u
!     v_t      - time tendency of v
!     t_t      - time tendency of t
!     p_t      - time tendency of 2d surface pressure
!     mype     - mpi integer task id
!
!   output argument list:
!     u        - zonal wind on subdomain
!     v        - meridional wind on subdomain
!     t        - virtual temperature on subdomain
!     q        - q on subdomain
!     oz       - ozone on subdomain
!     cw       - cloud water mixing ratio on subdomain
!
!   notes:
!     adjoint check performed succesfully on 2005-09-29 by d. kleist
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds,only: r_kind,i_kind
  use gridmod, only: lat2,lon2,nsig,istart,nlat,idvc5,bk5,&
      eta2_ll,wrf_nmm_regional,nems_nmmb_regional,regional,nthreads,jtstart,jtstop
  use constants, only: zero,half,two,rd,rcp
  use tendsmod, only: what9,prsth9,r_prsum9,prdif9,r_prdif9,pr_xsum9,pr_xdif9,&
      pr_ysum9,pr_ydif9,curvx,curvy,coriolis
  use guess_grids, only: ntguessig,&
      ges_teta,ges_prsi
  use gsi_metguess_mod, only: gsi_metguess_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use derivsmod, only: gsi_xderivative_bundle
  use derivsmod, only: gsi_yderivative_bundle
  implicit none

! Declare passed variables
  real(r_kind),dimension(lat2,lon2,nsig),intent(inout) :: u_t,v_t
  real(r_kind),dimension(lat2,lon2,nsig),intent(inout) :: t_t
  real(r_kind),dimension(lat2,lon2)     ,intent(in   ) :: p_t
  real(r_kind),dimension(lat2,lon2,nsig),intent(inout) :: st,vp,t
  real(r_kind),dimension(lat2,lon2)     ,intent(inout) :: p
  integer(i_kind)                       ,intent(in   ) :: mype
  logical                               ,intent(in   ) :: uvflag

! Declare local variables
  character(len=*),parameter::myname='calctends_no_ad'
  real(r_kind),dimension(lat2,lon2,nsig):: u,v
  real(r_kind),dimension(lat2,lon2,nsig+1):: pri
  real(r_kind),dimension(lat2,lon2,nsig):: u_x,u_y,v_x,v_y,t_x,t_y
  real(r_kind),dimension(lat2,lon2,nsig+1):: pri_x,pri_y,prsth,what
  real(r_kind),dimension(lat2,lon2,nsig):: prsum,prdif,pr_xsum,pr_xdif,pr_ysum,&
       pr_ydif

  real(r_kind),dimension(lat2,lon2,nsig):: t_thor9
  real(r_kind),dimension(lat2,lon2):: sumkm1,sumvkm1,sum2km1,sum2vkm1
  real(r_kind) tmp,tmp2,tmp3,var,sumk,sumvk,sum2k,sum2vk
  integer(i_kind) i,j,k,ix,it,kk,ier,istatus

  real(r_kind),pointer,dimension(:,:,:) :: ges_u=>NULL()
  real(r_kind),pointer,dimension(:,:,:) :: ges_v=>NULL()
  real(r_kind),pointer,dimension(:,:,:) :: ges_tv=>NULL()

  real(r_kind),pointer,dimension(:,:,:) :: ges_u_lon=>NULL()
  real(r_kind),pointer,dimension(:,:,:) :: ges_v_lon=>NULL()
  real(r_kind),pointer,dimension(:,:,:) :: ges_tv_lon=>NULL()

  real(r_kind),pointer,dimension(:,:,:) :: ges_u_lat=>NULL()
  real(r_kind),pointer,dimension(:,:,:) :: ges_v_lat=>NULL()
  real(r_kind),pointer,dimension(:,:,:) :: ges_tv_lat=>NULL()

  it=ntguessig

  ier=0
  call gsi_bundlegetpointer(gsi_metguess_bundle(it),'u' ,ges_u, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(gsi_metguess_bundle(it),'v' ,ges_v, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(gsi_metguess_bundle(it),'tv',ges_tv,istatus);ier=istatus+ier
  if(ier/=0) then
     write(6,*) myname, ': pointers not found in met-guess, ier=', ier
     call stop2(999)
  endif

  ier=0
  call gsi_bundlegetpointer(gsi_xderivative_bundle(it),'u' ,ges_u_lon, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(gsi_xderivative_bundle(it),'v' ,ges_v_lon, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(gsi_xderivative_bundle(it),'tv',ges_tv_lon,istatus);ier=istatus+ier
  if(ier/=0) then
     write(6,*) myname, ': pointers not found in lon-derivatives, ier=', ier
     call stop2(999)
  endif

  ier=0
  call gsi_bundlegetpointer(gsi_yderivative_bundle(it),'u' ,ges_u_lat, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(gsi_yderivative_bundle(it),'v' ,ges_v_lat, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(gsi_yderivative_bundle(it),'tv',ges_tv_lat,istatus);ier=istatus+ier
  if(ier/=0) then
     write(6,*) myname, ': pointers not found in lat-derivatives, ier=', ier
     call stop2(999)
  endif

!$omp parallel do private(i,j,k,kk,tmp,tmp2,ix,&
!$omp                  tmp3,sumk,sumvk,sum2k,sum2vk,var)

  do kk=1,nthreads

!   zero arrays
    do k=1,nsig+1
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           pri(i,j,k)=zero
           pri_x(i,j,k)=zero
           pri_y(i,j,k)=zero
        end do
      end do
    end do

!   Put p_t in prsth and what for adjoint of calculating
!   full three-dimensional dp/dt

    do j=jtstart(kk),jtstop(kk)
      do i=1,lat2
        prsth(i,j,1)=   p_t(i,j)
        what (i,j,1)= - p_t(i,j)
      end do
    end do
    do k=1,nsig
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           u(i,j,k)=zero
           v(i,j,k)=zero
           u_x(i,j,k)=zero
           u_y(i,j,k)=zero
           v_x(i,j,k)=zero
           v_y(i,j,k)=zero
           t_x(i,j,k)=zero
           t_y(i,j,k)=zero
           prsum(i,j,k)=zero
           prdif(i,j,k)=zero
           pr_xsum(i,j,k)=zero
           pr_xdif(i,j,k)=zero
           pr_ysum(i,j,k)=zero
           pr_ydif(i,j,k)=zero
           what(i,j,k+1)=zero
           prsth(i,j,k+1)=zero
        end do
      end do
    end do
    do j=jtstart(kk),jtstop(kk)
      do i=1,lat2
        sumkm1(i,j)=zero
        sumvkm1(i,j)=zero
        sum2km1(i,j)=zero
        sum2vkm1(i,j)=zero
      end do
    end do

!   adjoint of sum 2d individual terms into 3d tendency arrays
!   because of sum arrays/dependencies, have to go from nsig --> 1

    if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then
      do k=1,nsig
        do j=jtstart(kk),jtstop(kk)
           do i=1,lat2
              ix=istart(mype+1)+i-2
              if (ix == 1 .or. ix == nlat) then
                 u_t(i,j,k)=zero ; v_t(i,j,k)=zero
              end if
           end do
        end do
      end do
    end if

    call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
                u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk))

    do k=nsig,1,-1

!     vertical summation terms for u,v

      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           sumk  =sumkm1  (i,j) - u_t   (i,j,k)
           sumvk =sumvkm1 (i,j) - v_t   (i,j,k)
           sum2k =sum2km1 (i,j) - rd*u_t(i,j,k)
           sum2vk=sum2vkm1(i,j) - rd*v_t(i,j,k)

           sumkm1(i,j)   = -u_t   (i,j,k)
           sumvkm1(i,j)  = -v_t   (i,j,k)
           sum2km1(i,j)  = -rd*u_t(i,j,k)
           sum2vkm1(i,j) = -rd*v_t(i,j,k)

! arrays tmp2 and tmp3 are from basic state variables

           tmp2=rd*ges_tv(i,j,k)*r_prsum9(i,j,k)
           tmp3=prdif9(i,j,k)*r_prsum9(i,j,k)
           t_y   (i,j,k)= t_y  (i,j,k) + sum2vk*tmp3
           var=sum2vk*r_prsum9(i,j,k)
           prdif (i,j,k)= prdif(i,j,k) + ges_tv_lat(i,j,k)*var
           prsum (i,j,k)= prsum(i,j,k) - ges_tv_lat(i,j,k)*tmp3*var
           sum2vkm1(i,j)=sum2vkm1(i,j) + sum2vk

           t_x  (i,j,k) = t_x  (i,j,k) + sum2k*tmp3
           var=sum2k*r_prsum9(i,j,k)
           prdif(i,j,k) = prdif(i,j,k) + ges_tv_lon(i,j,k)*var
           prsum(i,j,k) = prsum(i,j,k) - ges_tv_lon(i,j,k)*tmp3*var
           sum2km1(i,j) = sum2km1(i,j) + sum2k

           pr_ydif(i,j,k) = pr_ydif(i,j,k) + tmp2*sumvk
           pr_ysum(i,j,k) = pr_ysum(i,j,k) - tmp2*tmp3*sumvk
           var=tmp2*sumvk*r_prsum9(i,j,k)
           prsum  (i,j,k) = prsum  (i,j,k) + tmp3*var*pr_ysum9(i,j,k)
           prdif  (i,j,k) = prdif  (i,j,k) - var*pr_ysum9(i,j,k)

! tmp is a reused variable

           tmp = sumvk*( pr_ydif9(i,j,k) - (pr_ysum9(i,j,k)*tmp3) )
           prsum(i,j,k) = prsum(i,j,k) - var* &
              ( pr_ydif9(i,j,k) - (pr_ysum9(i,j,k)*tmp3) )
           sumvkm1(i,j)= sumvkm1(i,j)+ sumvk

           pr_xdif(i,j,k) = pr_xdif(i,j,k) + tmp2*sumk
           pr_xsum(i,j,k) = pr_xsum(i,j,k) - tmp2*tmp3*sumk
           var=tmp2*sumk*r_prsum9(i,j,k)
           prsum  (i,j,k) = prsum  (i,j,k) + tmp3*var*pr_xsum9(i,j,k)
           prdif  (i,j,k) = prdif  (i,j,k) - var*pr_xsum9(i,j,k)
           tmp = tmp + sumk*( pr_xdif9(i,j,k) - &
              (pr_xsum9(i,j,k)*tmp3) )
           prsum  (i,j,k) = prsum(i,j,k) - var* &
              ( pr_xdif9(i,j,k) - (pr_xsum9(i,j,k)*tmp3) )
           sumkm1   (i,j) = sumkm1 (i,j) + sumk

           t(i,j,k) = t(i,j,k) + rd*tmp*r_prsum9(i,j,k)
        end do
      end do

!     adjoint of vertical flux terms

      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           if(k < nsig) then
              tmp2=half*what9(i,j,k+1)*r_prdif9(i,j,k)

              tmp = -u_t(i,j,k)*(ges_u (i,j,k)-ges_u (i,j,k+1)) - &
                     v_t(i,j,k)*(ges_v (i,j,k)-ges_v (i,j,k+1)) - &
                     t_t(i,j,k)*(ges_tv(i,j,k)-ges_tv(i,j,k+1))

              t(i,j,k  ) = t(i,j,k  ) - t_t(i,j,k)*tmp2
              t(i,j,k+1) = t(i,j,k+1) + t_t(i,j,k)*tmp2
              u(i,j,k  ) = u(i,j,k  ) - u_t(i,j,k)*tmp2
              u(i,j,k+1) = u(i,j,k+1) + u_t(i,j,k)*tmp2
              v(i,j,k  ) = v(i,j,k  ) - v_t(i,j,k)*tmp2
              v(i,j,k+1) = v(i,j,k+1) + v_t(i,j,k)*tmp2

              prdif(i,j,k) = prdif(i,j,k) + (tmp2*r_prdif9(i,j,k))* &
                ( ((ges_tv(i,j,k)-ges_tv(i,j,k+1))*t_t(i,j,k)) + &
                  ((ges_u (i,j,k)-ges_u (i,j,k+1))*u_t(i,j,k)) + &
                  ((ges_v (i,j,k)-ges_v (i,j,k+1))*v_t(i,j,k)) )

              what(i,j,k+1) = what(i,j,k+1) + half*tmp*r_prdif9(i,j,k)
           end if
           if(k > 1) then
              tmp2=half*what9(i,j,k)*r_prdif9(i,j,k)

              tmp = - u_t(i,j,k)*(ges_u (i,j,k-1)-ges_u (i,j,k)) - &
                      v_t(i,j,k)*(ges_v (i,j,k-1)-ges_v (i,j,k)) - &
                      t_t(i,j,k)*(ges_tv(i,j,k-1)-ges_tv(i,j,k))

              t(i,j,k-1) = t(i,j,k-1) - t_t(i,j,k)*tmp2
              t(i,j,k  ) = t(i,j,k  ) + t_t(i,j,k)*tmp2
              u(i,j,k-1) = u(i,j,k-1) - u_t(i,j,k)*tmp2
              u(i,j,k  ) = u(i,j,k  ) + u_t(i,j,k)*tmp2
              v(i,j,k-1) = v(i,j,k-1) - v_t(i,j,k)*tmp2
              v(i,j,k  ) = v(i,j,k  ) + v_t(i,j,k)*tmp2

              prdif(i,j,k) = prdif(i,j,k) + (tmp2*r_prdif9(i,j,k))* &
                ( ((ges_tv(i,j,k-1)-ges_tv(i,j,k))*t_t(i,j,k)) + &
                  ((ges_u (i,j,k-1)-ges_u (i,j,k))*u_t(i,j,k)) + &
                  ((ges_v (i,j,k-1)-ges_v (i,j,k))*v_t(i,j,k)) )

              what(i,j,k) = what(i,j,k) + half*tmp*r_prdif9(i,j,k)
           end if

!       Now finish up with adjoint of the rest of the terms
!       tmp is now a basic state variable, whereas tmp2 is used in computation

           tmp=rd*ges_tv(i,j,k)*r_prsum9(i,j,k)

           pr_ysum(i,j,k) = pr_ysum(i,j,k) - tmp*v_t(i,j,k)
           prsum  (i,j,k) = prsum  (i,j,k) + tmp*v_t(i,j,k)*pr_ysum9(i,j,k)* &
              r_prsum9(i,j,k)

           tmp2 = - v_t(i,j,k)*pr_ysum9(i,j,k)

           pr_xsum(i,j,k) = pr_xsum(i,j,k) - tmp*u_t(i,j,k)
           prsum  (i,j,k) = prsum  (i,j,k) + tmp*u_t(i,j,k)*pr_xsum9(i,j,k)* &
              r_prsum9(i,j,k)
           tmp2 = tmp2 - u_t(i,j,k)*pr_xsum9(i,j,k)

           t(i,j,k) = t(i,j,k) + rd*tmp2*r_prsum9(i,j,k)

           u  (i,j,k) = u  (i,j,k) - v_t(i,j,k)*(ges_v_lon(i,j,k) - two*curvy(i,j)* &
               ges_u(i,j,k) + coriolis(i,j))
           v_x(i,j,k) = v_x(i,j,k) - v_t(i,j,k)*ges_u(i,j,k)
           v  (i,j,k) = v  (i,j,k) - v_t(i,j,k)*(ges_v_lat(i,j,k) - two*curvy(i,j)* &
               ges_v(i,j,k))
           v_y(i,j,k) = v_y(i,j,k) - v_t(i,j,k)*ges_v(i,j,k)

           u  (i,j,k) = u  (i,j,k) - u_t(i,j,k)*(ges_u_lon(i,j,k) - two*curvx(i,j)* &
               ges_u(i,j,k))
           u_x(i,j,k) = u_x(i,j,k) - u_t(i,j,k)*ges_u(i,j,k)
           v  (i,j,k) = v  (i,j,k) - u_t(i,j,k)*(ges_u_lat(i,j,k) - two*curvx(i,j)* &
               ges_v(i,j,k) - coriolis(i,j))
           u_y(i,j,k) = u_y(i,j,k) - u_t(i,j,k)*ges_v(i,j,k)

        end do  !end do i
      end do    !end do j
    end do      !end do k

!   adjoint of calculation of vertical velocity

    if ( (.not.regional) .AND. (idvc5==3)) then

!     Basic state horizontal temperature tendency

!     Get horizontal part of temperature tendency for vertical velocity term

      do k=1,nsig
        do j=jtstart(kk),jtstop(kk)
           do i=1,lat2
              tmp=-rd*ges_tv(i,j,k)*r_prsum9(i,j,k)
              t_thor9(i,j,k)=-ges_u(i,j,k)*ges_tv_lon(i,j,k) - &
                   ges_v(i,j,k)*ges_tv_lat(i,j,k)
              t_thor9(i,j,k)=t_thor9(i,j,k) -tmp*rcp * ( ges_u(i,j,k)*pr_xsum9(i,j,k) + &
                 ges_v(i,j,k)*pr_ysum9(i,j,k) + &
                 prsth9(i,j,k) + prsth9(i,j,k+1) )
           end do
        end do
      end do
      call getvvel_ad(t,t_t,t_thor9,prsth,prdif,what,jtstart(kk),jtstop(kk))
    else
      if (wrf_nmm_regional.or.nems_nmmb_regional) then
        do k=2,nsig
           do j=jtstart(kk),jtstop(kk)
              do i=1,lat2
                 prsth(i,j,1) = prsth(i,j,1) - eta2_ll (k)*what(i,j,k)
                 prsth(i,j,k) = prsth(i,j,k) + what(i,j,k)
              end do
           end do
        end do
      else
        do k=2,nsig
           do j=jtstart(kk),jtstop(kk)
              do i=1,lat2
                 prsth(i,j,1) = prsth(i,j,1) - bk5     (k)*what(i,j,k)
                 prsth(i,j,k) = prsth(i,j,k) + what(i,j,k)
              end do
           end do
        end do
      end if
    end if

!   Horizontal Part of temperature tendency, now that adjoint of
!   vertical velocity is done

    do k=1,nsig
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           tmp=rd*ges_tv(i,j,k)*r_prsum9(i,j,k)

           tmp2 = t_t(i,j,k)*rcp*( ges_u(i,j,k)* &
              pr_xsum9(i,j,k) + &
              ges_v(i,j,k)*pr_ysum9(i,j,k) + &
              prsth9(i,j,k)+prsth9(i,j,k+1) )
           prsum(i,j,k) = prsum(i,j,k) - tmp2*tmp*r_prsum9(i,j,k)

           var=t_t(i,j,k)*tmp*rcp
           pr_xsum(i,j,k) = pr_xsum(i,j,k) + var*ges_u(i,j,k)
           pr_ysum(i,j,k) = pr_ysum(i,j,k) + var*ges_v(i,j,k)
           u      (i,j,k) = u      (i,j,k) + var*pr_xsum9(i,j,k)
           v      (i,j,k) = v      (i,j,k) + var*pr_ysum9(i,j,k)
           prsth  (i,j,k) = prsth  (i,j,k) + var
           prsth(i,j,k+1) = prsth(i,j,k+1) + var

           t(i,j,k) = t(i,j,k) + rd*tmp2*r_prsum9(i,j,k)

           u  (i,j,k) = u  (i,j,k) - t_t(i,j,k)*ges_tv_lon(i,j,k)
           t_x(i,j,k) = t_x(i,j,k) - t_t(i,j,k)*ges_u (i,j,k)
           v  (i,j,k) = v  (i,j,k) - t_t(i,j,k)*ges_tv_lat(i,j,k)
           t_y(i,j,k) = t_y(i,j,k) - t_t(i,j,k)*ges_v (i,j,k)
        end do
      end do
    end do

!   adjoint of horizontal portion of pressure tendency

    do k=1,nsig
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           u      (i,j,k) = u      (i,j,k) - prsth(i,j,k)*pr_xdif9(i,j,k)
           pr_xdif(i,j,k) = pr_xdif(i,j,k) - prsth(i,j,k)*ges_u(i,j,k)
           v      (i,j,k) = v      (i,j,k) - prsth(i,j,k)*pr_ydif9(i,j,k)
           pr_ydif(i,j,k) = pr_ydif(i,j,k) - prsth(i,j,k)*ges_v(i,j,k)
           u_x    (i,j,k) = u_x    (i,j,k) - prsth(i,j,k)*(prdif9(i,j,k))
           v_y    (i,j,k) = v_y    (i,j,k) - prsth(i,j,k)*(prdif9(i,j,k))
           prdif  (i,j,k) = prdif  (i,j,k) - prsth(i,j,k)*(ges_u_lon(i,j,k) + &
              ges_v_lat(i,j,k))
           prsth(i,j,k+1) = prsth(i,j,k+1) + prsth(i,j,k)
        end do
      end do
    end do

    do k=1,nsig
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           pri  (i,j,k  )=pri  (i,j,k  ) + (prsum  (i,j,k)+prdif  (i,j,k))
           pri  (i,j,k+1)=pri  (i,j,k+1) + (prsum  (i,j,k)-prdif  (i,j,k))
           pri_x(i,j,k  )=pri_x(i,j,k  ) + (pr_xsum(i,j,k)+pr_xdif(i,j,k))
           pri_x(i,j,k+1)=pri_x(i,j,k+1) + (pr_xsum(i,j,k)-pr_xdif(i,j,k))
           pri_y(i,j,k  )=pri_y(i,j,k  ) + (pr_ysum(i,j,k)+pr_ydif(i,j,k))
           pri_y(i,j,k+1)=pri_y(i,j,k+1) + (pr_ysum(i,j,k)-pr_ydif(i,j,k))
        end do
      end do
    end do

  end do

!  end of threading loop

  if(uvflag)then
     call tget_derivatives2uv(st,vp,t,pri,u,v,u_x,v_x,t_x,pri_x, &
                                         u_y,v_y,t_y,pri_y)
  else
     call tget_derivatives2(st,vp,t,pri,u,v,u_x,v_x,t_x,pri_x, &
                                      u_y,v_y,t_y,pri_y)
  end if

  call getprs_ad(p,t,pri)

  return
end subroutine calctends_no_ad


!-----------------------------------------------------------------------
!     Evaluate Force BOMD
!-----------------------------------------------------------------------
SUBROUTINE getforce
  use bb_module
  use atom_module, only: Natom,aa_atom,ki_atom,zn_atom,shift_aa_coordinates_atom
  use strfac_module
  use ps_local_module
  use ps_pcc_module
  use pseudopot_module
  use ps_nloc2_module
  use ps_nloc3_module
  use ps_nloc_mr_module
  use eion_module, only: calc_eion
  use force_module
  use cpmd_variables, only: Rion,Force,pmass,AMU,disp_switch &
       ,MB_0_CPMD,MB_1_CPMD,MB_0_SCF,MB_1_SCF
  use scf_module
  use array_bound_module, only: MB_0,MB_1,MBZ_0,MBZ_1,MSP_0,MSP_1
  use parallel_module, only: end_mpi_parallel, disp_switch_parallel
  use ps_nloc2_variables, only: prep_backup_uVunk_ps_nloc2
  use io_tools_module

  implicit none
  real(8) :: c
  integer :: a,Diter1,ierr

  !Diter1       = 100
  call IOTools_readIntegerKeyword( "DITER", Diter1 )
  c            = 1.d0/(2.d0*acos(-1.d0))
  aa_atom(:,:) = matmul(transpose(bb),Rion)*c
  call shift_aa_coordinates_atom( aa_atom )

  call calc_eion

  call construct_strfac
  call construct_ps_local
  call construct_ps_pcc
  call destruct_strfac

  select case(pselect)
  case(2)
     call prep_ps_nloc2
  case(3)
     call prep_ps_nloc3
  case(5)
     call prep_ps_nloc_mr
  end select

  MB_0=MB_0_SCF
  MB_1=MB_1_SCF

  call calc_scf( ierr, Diter1 )
  if ( ierr == -1 ) then
     if ( disp_switch ) write(*,*) "time limit !!!"
     call end_mpi_parallel
     stop "stop@getforce"
  end if
  if ( ierr == -2 ) then
     if ( disp_switch ) write(*,*) "SCF is not converged"
  end if

  MB_0=MB_0_CPMD
  MB_1=MB_1_CPMD

  call prep_backup_uVunk_ps_nloc2( MB_0,MB_1,MBZ_0,MBZ_1,MSP_0,MSP_1 )

  Force(:,:)=0.0d0
  call calc_force(Natom,Force)

  do a=1,Natom
     Force(:,a)=Force(:,a)/(pmass(zn_atom(ki_atom(a)))*AMU)
  enddo

  return
END SUBROUTINE getforce


      subroutine make_bigtri_lg(npoints,ntets,xcoords,nwds,ierror)
C#######################################################################
C
C     PURPOSE -
C  Find dimensions of a triangle that will enclose the point set
C
C     INPUT ARGUMENTS -
C
c  npoints - number of points in the mesh
C  ntets  - number of elements in the mesh
c
C     OUTPUT
C  ibigtet and xbigtet,ybigtet,zbigtet
C  boxsize etc will be set in common
C
C  CHANGE CONTROL
C
C  $Log: make_bigtri_lg.f,v $
C  Revision 2.00  2007/11/05 19:46:00  spchu
C  Import to CVS
C
CPVCS
CPVCS       Rev 1.13   30 Jan 2001 10:06:42   dcg
CPVCS    change test on number of arguments to command to accept coord of
CPVCS    big tri from input
CPVCS
CPVCS       Rev 1.12   30 Jan 2001 08:18:40   dcg
CPVCS    accept input triangle coordinates
CPVCS
CPVCS       Rev 1.11   26 Oct 2000 11:35:00   dcg
CPVCS    change calculation of coordinate of big triangle
CPVCS
CPVCS       Rev 1.10   Wed Apr 05 13:34:36 2000   nnc
CPVCS    Minor source modifications required by the Absoft compiler.
CPVCS
CPVCS       Rev 1.9   Thu Feb 17 14:50:50 2000   dcg
CPVCS    get rid of debug output
CPVCS
CPVCS       Rev 1.8   17 Feb 2000 12:06:26   jan
CPVCS
CPVCS       Rev 1.6   15 Feb 2000 13:59:20   jan
CPVCS    fixed error for collinear point check
CPVCS
CPVCS       Rev 1.5   08 Feb 2000 10:28:58   dcg
CPVCS    comment out bad tests (collinear, in plane) for now
CPVCS
CPVCS       Rev 1.4   Fri Nov 12 15:30:48 1999   dcg
CPVCS    check for collinear points
CPVCS
CPVCS       Rev 1.3   Thu Oct 07 16:43:52 1999   dcg
CPVCS    fix error in calculating coordinates from equation of plane
CPVCS
CPVCS       Rev 1.2   Wed Sep 01 15:55:30 1999   dcg
CPVCS    repair typo caused by previous fix
CPVCS
CPVCS       Rev 1.1   Wed Sep 01 12:43:20 1999   dcg
CPVCS    get mbndry from mesh object
CPVCS
CPVCS       Rev 1.0   Fri Mar 19 13:14:52 1999   dcg
CPVCS    Initial revision.
C#######################################################################
C
      implicit none
      include 'search.h'
      include 'chydro.h'
      include 'consts.h'
      real*8 depthx,depthy,depthz,xmeanl,a,b,c,d,s1,s2,
     *  ymeanl,zmeanl,xminl,yminl,zminl,xmaxl,ymaxl,zmaxl
      integer npoints,ntets,i,mbndry
      integer ipt1,ipt2,ierror,
     * leni,icmotype,ier,nwds
      pointer (ipitet,itet)
      pointer (ipjtet,jtet)
      integer itet(3,*),jtet(3,*)
	real*8 voltri,absofd
      pointer (ipitp1,itp1)
      integer itp1(*)
      pointer (ipimt1,imt1)
      integer imt1(*)
      pointer (ipxic,xic),(ipyic,yic),(ipzic,zic)
      real*8 xic(*),yic(*),zic(*),xcoords(*)
      character*32 cmo
      character*132 logmess
C
      ierror=0

      call cmo_get_name(cmo,ier)
C
      call cmo_get_info('mbndry',cmo,mbndry,leni,icmotype,ier)
      call cmo_get_info('xic',cmo,ipxic,leni,icmotype,ier)
      call cmo_get_info('yic',cmo,ipyic,leni,icmotype,ier)
      call cmo_get_info('zic',cmo,ipzic,leni,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,leni,icmotype,ier)
      call cmo_get_info('jtet',cmo,ipjtet,leni,icmotype,ier)
      call cmo_get_info('imt1',cmo,ipimt1,leni,icmotype,ier)
      call cmo_get_info('itp1',cmo,ipitp1,leni,icmotype,ier)
      ibigtet=npoints+1
c
c  see if coordinates are supplied
c
      if(nwds.ge.14) then
         xbigtet(1)=xcoords(1)
         ybigtet(1)=xcoords(2)
         zbigtet(1)=xcoords(3)
         xbigtet(2)=xcoords(4)
         ybigtet(2)=xcoords(5)
         zbigtet(2)=xcoords(6)
         xbigtet(3)=xcoords(7)
         ybigtet(3)=xcoords(8)
         zbigtet(3)=xcoords(9)
         xbigtet(4)=xcoords(10)
         ybigtet(4)=xcoords(11)
         zbigtet(4)=xcoords(12)
         go to 100
      endif
c
c find mins and maxs
c
      xminl=xic(1)
      xmaxl=xic(1)
      yminl=yic(1)
      ymaxl=yic(1)
      zminl=zic(1)
      zmaxl=zic(1)

      do i=2,npoints
         if(xic(i).lt.xminl) then
            xminl=xic(i)

         endif
         if(xic(i).gt.xmaxl) then
            xmaxl=xic(i)

         endif
         if(yic(i).lt.yminl) then
            yminl=yic(i)

         endif
         if(yic(i).gt.ymaxl) then
            ymaxl=yic(i)

         endif
         if(zic(i).lt.zminl) then
            zminl=zic(i)

         endif
         if(zic(i).gt.zmaxl) then
            zmaxl=zic(i)

         endif
      enddo
C  find BRICK THAT ENCLOSES ALL THE POINTS and midpoints of edges.
      xmeanl=0.5*(xminl+xmaxl)
      ymeanl=0.5*(yminl+ymaxl)
      zmeanl=0.5*(zminl+zmaxl)
      boxsizex=xmaxl-xminl
      boxsizey=ymaxl-yminl
      boxsizez=zmaxl-zminl
C        SET UP THE EQUATION OF THE PLANE FROM 3 POINTS.
C
      ipt1=1
      ipt2=npoints
c make sure the points are not collinear
c     if(abs(boxsizex).lt.smldistp.or.
c    *   abs(boxsizey).lt.smldistp) then
c        write(logmess,8)
c        call writloga('default',0,logmess,0,ier)
c        ierror=1
c        go to 9999
c     endif
c     do i=1,npoints-1
c       s1=(xmeanl-xic(ipt1))/(ymeanl-yic(ipt1))
c       s2=(xic(ipt2)-xmeanl)/(yic(ipt2)-ymeanl)
c       if(abs(s1-s2).gt.smldistp )go to 10
c       ipt2=npoints-i
c     enddo
c     write(logmess,8)
c8    format( 'All nodes are collinear')
c     call writloga('default',0,logmess,0,ier)
c     ierror=1
c     go to 9999
c
c tests for collinear points
c
c
c      call get_epsilon("epsilon1", eps)
      i = 3
      call volume_tri(xic(1), yic(1), zic(1),
     1                xic(2), yic(2), zic(2),
     1                xic(i), yic(i), zic(i),voltri)
      do while (i .lt. npoints .and. abs(voltri) .lt. epsilonr)
         i = i + 1
         call volume_tri(xic(1), yic(1), zic(1),
     1                   xic(2), yic(2), zic(2),
     1                   xic(i), yic(i), zic(i),voltri)
      end do
      if (i .eq. npoints .and. abs(voltri) .lt. epsilonr) then
         write(logmess,8)
8        format('All nodes are collinear')
         call writloga('default',0,logmess,0,ier)
         ierror=1
         go to 9999
      end if

c test to see if in same plane

C     SET UP THE EQUATION OF THE PLANE FROM THE 3 POINTS.
C
      a=  (yic(2)-yic(1))*(zic(i)-zic(1)) -
     &    (yic(i)-yic(1))*(zic(2)-zic(1))
      b=-((xic(2)-xic(1))*(zic(i)-zic(1)) -
     &    (xic(i)-xic(1))*(zic(2)-zic(1)))
      c=  (xic(2)-xic(1))*(yic(i)-yic(1)) -
     &    (xic(i)-xic(1))*(yic(2)-yic(1))
      d=a*xic(1)+b*yic(1)+c*zic(1)
      if (abs(d) .gt. epsilonr) then
         absofd=abs(d)
         a=a/absofd
         b=b/absofd
         c=c/absofd
         d=d/absofd
      end if
      do i = 3, npoints
	   if(abs((a*xic(i) + b*yic(i) + c*zic(i) - d)) .gt. epsilonr)
     1 then
         write(logmess,88)
88        format('Points are not in same plane')
         call writloga('default',0,logmess,0,ier)
         ierror=1
           end if
      end do

       depthx=3.0*boxsizex
       depthy=3.0*boxsizey
       depthz=3.0*boxsizez
c
       if ((depthx .ge. depthy) .and.
     *     (depthz .ge. depthy)) then
c
c        Bigtri is most parallel to the y=0 plane
c
            xbigtet(1)=xmeanl-0.75*depthx
            zbigtet(1)=zmeanl-0.70*depthz
            ybigtet(1)=-(a*xbigtet(1)+c*zbigtet(1)-d)/b
            xbigtet(2)=xmeanl+0.75*depthx
            zbigtet(2)=zmeanl-0.75*depthz
            ybigtet(2)=-(a*xbigtet(2)+c*zbigtet(2)-d)/b
            xbigtet(3)=1.01*xmeanl
            zbigtet(3)=zmeanl+max(depthx,depthz)
            ybigtet(3)=-(a*xbigtet(3)+c*zbigtet(3)-d)/b
c
      elseif ((depthy .ge. depthx) .and.
     *        (depthz .ge. depthx)) then
c
c        Bigtet is most parallel to the x=0 plane
            ybigtet(1)=ymeanl-0.75*depthy
            zbigtet(1)=zmeanl-0.70*depthz
            xbigtet(1)=-(b*ybigtet(1)+c*zbigtet(1)-d)/a
            ybigtet(2)=ymeanl+0.75*depthy
            zbigtet(2)=zmeanl-0.75*depthz
            xbigtet(2)=-(b*ybigtet(2)+c*zbigtet(2)-d)/a
            ybigtet(3)=1.01*ymeanl
            zbigtet(3)=zmeanl+1.5*max(depthy,depthz)
            xbigtet(3)=-(b*ybigtet(3)+c*zbigtet(3)-d)/a
c
      elseif ((depthy .ge. depthz) .and.
     *        (depthx .ge. depthz)) then
c
c        Bigtri is most parallel to the z=0 plane
c
            xbigtet(1)=xmeanl-0.75*depthx
            ybigtet(1)=ymeanl-0.70*depthy
            zbigtet(1)=-(a*xbigtet(1)+b*ybigtet(1)-d)/c
            xbigtet(2)=xmeanl+0.75*depthx
            ybigtet(2)=ymeanl-0.75*depthy
            zbigtet(2)=-(a*xbigtet(2)+b*ybigtet(2)-d)/c
            xbigtet(3)=1.01*xmeanl
            ybigtet(3)=ymeanl+1.5*max(depthx,depthy)
            zbigtet(3)=-(a*xbigtet(3)+b*ybigtet(3)-d)/c
c
      endif
c
 100  ntets=ntetexcl+1
      itet(1,ntets)=npoints+1
      itet(2,ntets)=npoints+2
      itet(3,ntets)=npoints+3
      jtet(1,ntets)=mbndry
      jtet(2,ntets)=mbndry
      jtet(3,ntets)=mbndry
      xic (ibigtet  )=xbigtet(1)
      yic (ibigtet  )=ybigtet(1)
      zic (ibigtet  )=zbigtet(1)
      itp1(ibigtet  )=ifitpini
      imt1(ibigtet  )=0
      xic (ibigtet+1)=xbigtet(2)
      yic (ibigtet+1)=ybigtet(2)
      zic (ibigtet+1)=zbigtet(2)
      itp1(ibigtet+1)=ifitpini
      imt1(ibigtet+1)=0
      xic (ibigtet+2)=xbigtet(3)
      yic (ibigtet+2)=ybigtet(3)
      zic (ibigtet+2)=zbigtet(3)
      itp1(ibigtet+2)=ifitpini
      imt1(ibigtet+2)=0
c
 9999 continue
      return
      end


C MULTI-ADD: Program to add many maps together
C ---------
C
C Multi add takes as input a file name and reads from the redtape a
C list of maps in the standard map catalogue to add together.
C Output is to the map specified in the call to the routine.
C-

       include '../include/anmap_sys_pars.inc'
       include '/mrao/include/iolib_constants.inc'
       include '/mrao/include/chrlib_functions.inc'

C Local variables
C ---------------
C  exit command
       character*80       command
C  data records
       real*4             in_rec(1024), out_rec(1024)
       real*4             out_image(1024*1024)
C  redtape buffer
       real*4             redtape_buffer(1024)
C  record containing list of maps; this will be a record in the extra
C  redtape slot of a standard format map.  The first 16 bytes of the
C  record are therefore reserved words.
       integer            map_list(128)
C    number of maps in list
       integer            nmaps
       equivalence       (map_list(5), nmaps)
C    start record for maps in list
       integer            start
       equivalence       (map_list(6), start)
C    length of each record in list
       integer            len_record
       equivalence       (map_list(7), len_record)
C    output map in catalogue
       integer            map_out
       equivalence       (map_list(8), map_out)
C  maximum number of maps to be added to list
       integer            max_maps
       parameter         (max_maps = 30)
C  map mini redtape
       integer            minirt(10)
C  define entry for each map
       integer            map_record(4)
       integer            map_entry
       equivalence       (map_record(1), map_entry)
       integer            map_directory
       equivalence       (map_record(2), map_directory)
       real*4             scale_factor
       equivalence       (map_record(3), scale_factor)
       real*4             zero_level
       equivalence       (map_record(4), zero_level)
C  arrays of information for each map
       integer            iunit(max_maps)
       real*4             scale(max_maps)
       real*4             zero(max_maps)
       real*4             blank(max_maps)
       integer            redtape(512,max_maps)
C  "single-valued" variables
       character*(iolen_file)
     *                    out_file, filename
       integer            iout
       integer            uv_range(4), data_type, usize,
     *                    iu, iv, i, n, jj
       real*4             zmnx(2)
       integer            izmnx(4)
C  character variables
       character          source*80, program*20
C  status word
       integer            status

C initialise
       status = 0
       call io_setexc(.true.,status)
       call io_initio
       call io_setesc(.true.)
       call cmd_init(status)
       call mapcat_open(status)

C read output map from command line, open and read redtape
       call io_getfil('Output-Map-File : ',' ',out_file,status)
       call opemap(iout,out_file,'WRITE',0,status)
       call rdredt(iout,0,status)
       call enredt(uv_range,data_type,status)
       call enxrec('ADD-MAPS',map_list,status)
       call dpredt(redtape_buffer,status)
       if (status.ne.0) goto 999

C loop, open input maps
       do n=1,nmaps
         do i=1,len_record
           map_record(i) = map_list(i + start-1 + (n-1)*len_record )
         end do
         call mapcat_enqrt(map_entry,filename,minirt,status)
         call opemap(iunit(n),filename,'READ',0,status)
         call rdredt(iunit(n),0,status)
         call ennull(blank(n),status)
         call dpredt(redtape(1,n),status)
         if (status.ne.0) goto 999
         scale(n) = scale_factor
         zero(n) = zero_level
       end do
       if (status.ne.0) goto 999

C do the addition
       zmnx(1) = -1.0E+30
       zmnx(2) =  1.0E+30
       usize = uv_range(2) - uv_range(1) + 1
       jj = 0
       do iv = uv_range(3),uv_range(4),-1
         do iu=1,usize
           out_rec(iu) = 0.0
         end do
         do n=1,nmaps
           call ldredt(redtape(1,n),status)
           call rdrow(iunit(n),iv,in_rec(1),status)
           do iu = 1,usize
             if (in_rec(iu).eq.blank(n)) then
               out_rec(iu) = blank(1)
             end if
             if (out_rec(iu).ne.blank(1)) then
               out_rec(iu) = out_rec(iu) +
     *                       (in_rec(iu)-zero(n))*scale(n)
             end if
           end do
         end do
         do iu = 1,usize
            if (out_rec(iu).gt.zmnx(1)) then
              zmnx(1) = out_rec(iu)
              izmnx(1) = uv_range(1) + iu - 1
              izmnx(2) = iv
            end if
            if (out_rec(iu).lt.zmnx(2)) then
              zmnx(2) = out_rec(iu)
              izmnx(3) = uv_range(1) + iu - 1
              izmnx(4) = iv
            end if
         end do
         call ldredt(redtape_buffer,status)
         if (status.ne.0) goto 999
         do iu=1,usize
           jj = jj + 1
           out_image(jj) = out_rec(iu)
         end do
       end do

C Update the TEXT of the redtape and map catalogue entry
       call ldredt(redtape_buffer,status)
       call adredt('created','MULTIADD',status)
       call mapcat_enqsr(map_out,source,program,status)
       call mapcat_setsr(map_out,source,program,status)
       call stnull(blank(1),status)
       call stscal(zmnx,izmnx,status)
       call wrredt(iout,0,status)
       call wrmap(iout,out_image,status)

C clear allocation to map
       call mapcat_acc(map_out,'CLEAR',status)

C close all maps
999    continue
       close (iout)

C close input maps
       do n=1,nmaps
         close (iunit(n))
       end do

C close map catalogue
       call mapcat_close(status)

C enable escape character
       call io_setesc( .false. )

C check STATUS value and report completion to the output device
       call cmd_err(status,'MULTI-ADD','Failed ')
       if (status.eq.0) then
         call io_enqout(iout)
         write(iout,'(1X,A,I3)')
     *         '.. Multi-Add completed to catalogue entry ',map_out
       else
         call io_enqout(iout)
         write(iout,'(1X,A,I3)')
     *         '.. Multi-Add Failed to construct map ',map_out
       end if
       call cmd_end( status )
       status = 0
       end


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

#include "error.inc"

program order

use libAtoms_module
use libatoms_misc_utils_module

implicit none

  type(Atoms) at, at2
  logical, dimension(:), allocatable :: atomdone
  integer error, i, j, k, jj, nn

  call system_initialise(verbosity=PRINT_SILENT)

  do
     call read(at, 'stdin', error=error)
     if (error /= 0) then
        if (error == ERROR_IO_EOF) then
	   exit
	else
	   HANDLE_ERROR(error)
	endif
     endif

     call set_cutoff(at, 1.2_dp)
     call calc_connect(at)

     call initialise(at2, at%N, at%lattice)
     allocate(atomdone(at%N))
     atomdone = .false.
     k = 1
     call print(at)

     do i=1,at%N
        if(atomdone(i) .eqv. .true.) cycle
        at2%species(:,k) = at%species(:,i)
        at2%pos(:,k) = at%pos(:,i)
        k = k+1
        atomdone(i) = .true.
        nn = n_neighbours(at, i)
        if(nn > 0) then
           do j=1,nn
              jj = neighbour(at, i, j)
              if(atomdone(jj) .eqv. .true.) cycle
              at2%species(:,k) = at%species(:,jj)
              at2%pos(:,k) = at%pos(:,jj)
              k = k+1
              atomdone(jj) = .true.
           end do
        endif
     end do
     deallocate(atomdone)

     call verbosity_push(PRINT_NORMAL)
     call write(at2, 'stdout')
     call verbosity_pop()
     call finalise(at2)

  enddo
  call system_finalise()

end program order


!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine structure_opt
use scf_data
implicit none
integer :: iatom
real(8) :: alpha

alpha=1.d-1

do iatom=1,MI
  if(istopt_a(iatom)==1)then
    Rion(1:3,iatom)=Rion(1:3,iatom)+alpha*rforce(1:3,iatom)
  end if
end do

end subroutine structure_opt


!
!     -------------------------------------------------------------
!      T W O P A R T I C L E 3 3
!     -------------------------------------------------------------
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
!     OF TWO PARTICLE OPERATOR IN CASE :       N'1 = N1 - 1        *
!                                              N'2 = N2 + 1        *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
      SUBROUTINE TWOPARTICLE33(IA, IB, IC, IIA, IIB, IIC, IID)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE MEDEFN_C
      USE TRK_C
      USE TRK2_C
      USE PERMAT_C
      USE KAMPAS_C
      USE CASEOP_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  12:23:13  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE two33a_I
      USE two33b_I
      USE hibff_I
      USE ittk_I
      USE itrexg2_I
      USE itrexg_I
      USE ssc_I
      USE sooc_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: IA
      INTEGER  :: IB
      INTEGER  :: IC
      INTEGER  :: IIA
      INTEGER  :: IIB
      INTEGER  :: IIC
      INTEGER  :: IID
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I1, I2, IP, IKK, IG, I, KL
!-----------------------------------------------
      IF (IHSH <= 2) RETURN
      CALL HIBFF (IA, IB, IC, IA, 3)
      IF (ITTK(1,IK1(6),ID1(6)) == 0) RETURN
      IF (ITTK(1,IK2(6),ID2(6)) == 0) RETURN
      IF (IABS(IK3(6)-ID3(6)) > 2) RETURN
      IF (ITTK(2*IK1(3),IK1(5),ID1(5)) == 0) RETURN
      IF (ITTK(2*IK2(3),IK2(5),ID2(5)) == 0) RETURN
      IF (IABS(IK3(5)-ID3(5)) > 4*IK3(3)) RETURN
      IRS = 0
      IW1(1,:) = 0
      IW1(2,:) = 0
      IRL = 0
      IF (IOCASE == 1) THEN
! Spin-Spin operator
         IP = ITREXG2(LJ(IA),LJ(IB),LJ(IC),LJ(IC),IKK) + 1
      ELSE IF (IOCASE == 2) THEN
! Spin-other-orbit operator
         IP = ITREXG(LJ(IA),LJ(IB),LJ(IC),LJ(IC),IKK) + 1
      ENDIF
      IF (IKK > 0) THEN
         IG = IP + IKK - 1
         DO I = IP, IG
            KL = I - 1
!
            IF (IOCASE == 1) THEN
! Spin-spin operator
               CALL SSC (IG, KL, IA, IB, IC, IC, IB, IC, IA, IC, KL, TWO33A)
            ELSE IF (IOCASE == 2) THEN
! Spin-other-orbit operator
               CALL SOOC (IG, KL, IA, IB, IC, IC, IB, IC, IA, IC, KL, TWO33A)
            ENDIF
!
         END DO
      ENDIF
      IF (IOCASE == 1) THEN
! Spin-Spin operator
         IP = ITREXG2(LJ(IA),LJ(IC),LJ(IB),LJ(IC),IKK) + 1
      ELSE IF (IOCASE == 2) THEN
! Spin-other-orbit operator
         IP = ITREXG(LJ(IA),LJ(IC),LJ(IB),LJ(IC),IKK) + 1
      ENDIF
      IF (IKK <= 0) RETURN
      IG = IP + IKK - 1
      DO I = IP, IG
         KL = I - 1
         IF (IOCASE == 1) THEN
! Spin-spin operator
            CALL SSC (IG, KL, IA, IB, IC, IC, IC, IB, IA, IC, KL, TWO33B)
         ELSE IF (IOCASE == 2) THEN
! Spin-other-orbit operator
            CALL SOOC (IG, KL, IA, IB, IC, IC, IC, IB, IA, IC, KL, TWO33B)
         ENDIF
      END DO
      RETURN
      END SUBROUTINE TWOPARTICLE33


*DECK DSOLPK
      SUBROUTINE DSOLPK (NEQ, Y, SAVF, X, EWT, WM, IWM, F, PSOL)
      EXTERNAL F, PSOL
      INTEGER NEQ, IWM
      DOUBLE PRECISION Y, SAVF, X, EWT, WM
      DIMENSION NEQ(*), Y(*), SAVF(*), X(*), EWT(*), WM(*), IWM(*)
      INTEGER IOWND, IOWNS,
     1   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
     2   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
     3   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
      INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT,
     1   NNI, NLI, NPS, NCFN, NCFL
      DOUBLE PRECISION ROWNS,
     1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND
      DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN
      COMMON /DLS001/ ROWNS(209),
     1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND,
     2   IOWND(6), IOWNS(6),
     3   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
     4   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
     5   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
      COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN,
     1   JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT,
     2   NNI, NLI, NPS, NCFN, NCFL
C-----------------------------------------------------------------------
C This routine interfaces to one of DSPIOM, DSPIGMR, DPCG, DPCGS, or
C DUSOL, for the solution of the linear system arising from a Newton
C iteration.  It is called if MITER .ne. 0.
C In addition to variables described elsewhere,
C communication with DSOLPK uses the following variables:
C WM    = real work space containing data for the algorithm
C         (Krylov basis vectors, Hessenberg matrix, etc.)
C IWM   = integer work space containing data for the algorithm
C X     = the right-hand side vector on input, and the solution vector
C         on output, of length N.
C IERSL = output flag (in Common):
C         IERSL =  0 means no trouble occurred.
C         IERSL =  1 means the iterative method failed to converge.
C                    If the preconditioner is out of date, the step
C                    is repeated with a new preconditioner.
C                    Otherwise, the stepsize is reduced (forcing a
C                    new evaluation of the preconditioner) and the
C                    step is repeated.
C         IERSL = -1 means there was a nonrecoverable error in the
C                    iterative solver, and an error exit occurs.
C This routine also uses the Common variables TN, EL0, H, N, MITER,
C DELT, EPCON, SQRTN, RSQRTN, MAXL, KMP, MNEWT, NNI, NLI, NPS, NCFL,
C LOCWP, LOCIWP.
C-----------------------------------------------------------------------
      INTEGER IFLAG, LB, LDL, LHES, LIOM, LGMR, LPCG, LP, LQ, LR,
     1   LV, LW, LWK, LZ, MAXLP1, NPSL
      DOUBLE PRECISION DELTA, HL0
C
      IERSL = 0
      HL0 = H*EL0
      DELTA = DELT*EPCON
      GO TO (100, 200, 300, 400, 900, 900, 900, 900, 900), MITER
C-----------------------------------------------------------------------
C Use the SPIOM algorithm to solve the linear system P*x = -f.
C-----------------------------------------------------------------------
 100  CONTINUE
      LV = 1
      LB = LV + N*MAXL
      LHES = LB + N
      LWK = LHES + MAXL*MAXL
      CALL DCOPY (N, X, 1, WM(LB), 1)
      CALL DSCAL (N, RSQRTN, EWT, 1)
      CALL DSPIOM (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, KMP, DELTA,
     1   HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES), IWM,
     2   LIOM, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG)
      NNI = NNI + 1
      NLI = NLI + LIOM
      NPS = NPS + NPSL
      CALL DSCAL (N, SQRTN, EWT, 1)
      IF (IFLAG .NE. 0) NCFL = NCFL + 1
      IF (IFLAG .GE. 2) IERSL = 1
      IF (IFLAG .LT. 0) IERSL = -1
      RETURN
C-----------------------------------------------------------------------
C Use the SPIGMR algorithm to solve the linear system P*x = -f.
C-----------------------------------------------------------------------
 200  CONTINUE
      MAXLP1 = MAXL + 1
      LV = 1
      LB = LV + N*MAXL
      LHES = LB + N + 1
      LQ = LHES + MAXL*MAXLP1
      LWK = LQ + 2*MAXL
      LDL = LWK + MIN(1,MAXL-KMP)*N
      CALL DCOPY (N, X, 1, WM(LB), 1)
      CALL DSCAL (N, RSQRTN, EWT, 1)
      CALL DSPIGMR (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, MAXLP1, KMP,
     1   DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES),
     2   WM(LQ), LGMR, WM(LOCWP), IWM(LOCIWP), WM(LWK), WM(LDL), IFLAG)
      NNI = NNI + 1
      NLI = NLI + LGMR
      NPS = NPS + NPSL
      CALL DSCAL (N, SQRTN, EWT, 1)
      IF (IFLAG .NE. 0) NCFL = NCFL + 1
      IF (IFLAG .GE. 2) IERSL = 1
      IF (IFLAG .LT. 0) IERSL = -1
      RETURN
C-----------------------------------------------------------------------
C Use DPCG to solve the linear system P*x = -f
C-----------------------------------------------------------------------
 300  CONTINUE
      LR = 1
      LP = LR + N
      LW = LP + N
      LZ = LW + N
      LWK = LZ + N
      CALL DCOPY (N, X, 1, WM(LR), 1)
      CALL DPCG (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0,
     1          JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ),
     2          LPCG, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG)
      NNI = NNI + 1
      NLI = NLI + LPCG
      NPS = NPS + NPSL
      IF (IFLAG .NE. 0) NCFL = NCFL + 1
      IF (IFLAG .GE. 2) IERSL = 1
      IF (IFLAG .LT. 0) IERSL = -1
      RETURN
C-----------------------------------------------------------------------
C Use DPCGS to solve the linear system P*x = -f
C-----------------------------------------------------------------------
 400  CONTINUE
      LR = 1
      LP = LR + N
      LW = LP + N
      LZ = LW + N
      LWK = LZ + N
      CALL DCOPY (N, X, 1, WM(LR), 1)
      CALL DPCGS (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0,
     1           JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ),
     2           LPCG, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG)
      NNI = NNI + 1
      NLI = NLI + LPCG
      NPS = NPS + NPSL
      IF (IFLAG .NE. 0) NCFL = NCFL + 1
      IF (IFLAG .GE. 2) IERSL = 1
      IF (IFLAG .LT. 0) IERSL = -1
      RETURN
C-----------------------------------------------------------------------
C Use DUSOL, which interfaces to PSOL, to solve the linear system
C (no Krylov iteration).
C-----------------------------------------------------------------------
 900  CONTINUE
      LB = 1
      LWK = LB + N
      CALL DCOPY (N, X, 1, WM(LB), 1)
      CALL DUSOL (NEQ, TN, Y, SAVF, WM(LB), EWT, N, DELTA, HL0, MNEWT,
     1   PSOL, NPSL, X, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG)
      NNI = NNI + 1
      NPS = NPS + NPSL
      IF (IFLAG .NE. 0) NCFL = NCFL + 1
      IF (IFLAG .EQ. 3) IERSL = 1
      IF (IFLAG .LT. 0) IERSL = -1
      RETURN
C----------------------- End of Subroutine DSOLPK ----------------------
      END