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

! Porter and Strong 2005 external radiation field module
module m_source_external_ps05

   use m_kind_parameters
   use m_constants_parameters
   use m_maths
   use m_source

   implicit none

   private
   public :: source_external_ps05

   ! porter and strong 2005 radiation field
   type,extends(source_external) :: source_external_ps05

      contains

      procedure :: initialise

   end type

   contains

   ! set up Porter and Strong 2005 interstellar radiation field
   subroutine initialise(self,position,velocity,&
      &temperature,luminosity,beta,wavelength_min,wavelength_max,n_wavelength,&
      &radius,dilution,gal_r,gal_z,g_0,add_cmb,mass,age,metallicity,luminosity_file)

      ! argument declarations
      class(source_external_ps05),intent(inout) :: self           ! source object
      real(kind=rel_kind),intent(in) :: position(n_dim)           ! position of source
      real(kind=rel_kind),intent(in) :: velocity(n_dim)           ! velocity of source
      real(kind=rel_kind),intent(in),optional :: temperature      ! temperature of source
      real(kind=rel_kind),intent(in),optional :: luminosity       ! luminosity of source
      real(kind=rel_kind),intent(in),optional :: beta             ! greybody exponent
      real(kind=rel_kind),intent(in),optional :: wavelength_min   ! minimum wavelength
      real(kind=rel_kind),intent(in),optional :: wavelength_max   ! maximum wavelength
      integer(kind=int_kind),intent(in),optional :: n_wavelength  ! number of wavelength points
      real(kind=rel_kind),intent(in),optional :: radius           ! radius of source (required)
      real(kind=rel_kind),intent(in),optional :: dilution         ! blackbody dilution factor
      real(kind=rel_kind),intent(in),optional :: gal_r            ! galactic radius (required)
      real(kind=rel_kind),intent(in),optional :: gal_z            ! galactic height (required)
      real(kind=rel_kind),intent(in),optional :: g_0              ! optional g_0 normalisation (applicable)
      logical(kind=log_kind),intent(in),optional :: add_cmb       ! add cosmic microwave background (required)
      real(kind=rel_kind),intent(in),optional :: mass             ! mass of star
      real(kind=rel_kind),intent(in),optional :: age              ! age of star
      real(kind=rel_kind),intent(in),optional :: metallicity      ! metallicity of star
      character(kind=chr_kind,len=string_length),intent(in),optional :: luminosity_file   ! mono luminosity file name

      ! variable declarations
      integer(kind=int_kind) :: i                                       ! counter
      integer(kind=int_kind) :: j                                       ! counter
      integer(kind=int_kind) :: k                                       ! counter
      integer(kind=int_kind) :: n_wavelength_file                       ! number of wavelengths
      real(kind=rel_kind) :: dummy                                      ! dummy variable
      real(kind=rel_kind),allocatable :: gal_r_array(:)                 ! galactic radius array
      real(kind=rel_kind),allocatable :: gal_z_array(:)                 ! galactic height array
      real(kind=rel_kind),allocatable :: energy_density_array(:,:,:)    ! energy density from file
      character(kind=chr_kind,len=3) :: r_string(9)                     ! file name substrings
      character(kind=chr_kind,len=3) :: z_string(10)                    ! file name substrings

      ! set parameters
      n_wavelength_file=505
      r_string=(/"0  ","2  ","4  ","6  ","8.5","12 ","16 ","20 ","30 "/)
      z_string=(/"0  ","0.1","0.2","0.5","1  ","2  ","5  ","10 ","20 ","30 "/)

      ! set variables
      self%position=position
      self%velocity=velocity
      self%radius=radius

      ! allocate arrays
      allocate(self%wavelength_array(n_wavelength_file))
      allocate(self%intensity_array(n_wavelength_file))
      allocate(self%norm_intensity_array(n_wavelength_file))
      allocate(self%cum_intensity_array(n_wavelength_file))
      allocate(gal_r_array(size(r_string)))
      allocate(gal_z_array(size(z_string)))

      ! read in wavelength array
      open(1,file="./isrfdata/Standard_0_0_0_Flux.dat")
      do i=1,n_wavelength_file
         read(1,*) self%wavelength_array(i)
      end do
      close(1)

      ! read in gal_r_array
      do i=1,size(r_string)
         read(r_string(i),*) gal_r_array(i)
      end do

      ! read in gal_z_array
      do i=1,size(z_string)
         read(z_string(i),*) gal_z_array(i)
      end do

      ! allocate flux array
      allocate(energy_density_array(size(r_string),size(z_string),n_wavelength_file))

      ! read in fluxes (funny order, so that interpolation uses contiguous array slice)
      do j=1,size(z_string)
         do i=1,size(r_string)

            open(1,file="./isrfdata/Standard_"//trim(r_string(i))//"_0_"//trim(z_string(j))//"_Flux.dat")
            do k=1,n_wavelength_file
               read(1,*) dummy,energy_density_array(i,j,k)
            end do
            close(1)

         end do
      end do

      ! build intensity array
      do i=1,n_wavelength_file

         ! interpolate energy density (lambda eV cm^-3) and convert to intensity (erg s^-1 sr^-1 cm^-2 micron^-1)
         self%intensity_array(i)=&
            &lookup_and_geo_interpolate(gal_r,gal_z,gal_r_array,gal_z_array,energy_density_array(:,:,i))*&
            &0.0038222687_rel_kind/self%wavelength_array(i)

      end do

      ! calculate g_0
      self%g_0=trapz_intgr(pack(self%wavelength_array,self%wavelength_array<0.20664032_rel_kind),&
         &pack(self%intensity_array,self%wavelength_array<0.20664032_rel_kind))/1.2e-4_rel_kind

      ! override g_0, if argument present
      if (present(g_0)) then

         self%intensity_array=self%intensity_array*g_0/self%g_0
         self%g_0=g_0

      end if

      ! add cosmic microwave background
      if (add_cmb) self%intensity_array=self%intensity_array+planck_lambda(self%wavelength_array,2.72548_rel_kind)

      ! calculate ave. intensity etc
      self%bolometric_intensity=trapz_intgr(self%wavelength_array,self%intensity_array)
      self%luminosity=self%bolometric_intensity*4._rel_kind*pi**2*radius**2

      ! normalise intensity and calculate cumulative distribution
      self%norm_intensity_array=self%intensity_array/self%bolometric_intensity
      self%cum_intensity_array=cum_dist_func(self%wavelength_array,self%intensity_array,.true._log_kind)

      return

   end subroutine

end module


      PROGRAM KPHF_CONST
      USE MOD_ZA  ! HYCOM array I/O interface
      IMPLICIT NONE
C
C     FLUX ARRAYS.
C
      INTEGER, ALLOCATABLE :: MSK(:,:)
      REAL*4,  ALLOCATABLE :: PLON(:,:),PLAT(:,:),XAF(:,:),YAF(:,:)
      REAL*4,  ALLOCATABLE :: FLD(:,:)
C
      CHARACTER PREAMBL(5)*79
C
C     NAMELIST.
C
      INTEGER          JPR
      COMMON/NPROCS/   JPR
      SAVE  /NPROCS/
C
      CHARACTER*40     CTITLE
      CHARACTER*8      CNAME
      NAMELIST/AFTITL/ CTITLE,CNAME
      REAL*4           FMON(12)
      REAL*8           FINC,FSTART,WSTART,TSTART,TMAX
      NAMELIST/AFTIME/ FINC,FSTART,WSTART,TSTART,TMAX
      NAMELIST/AFCNST/ FMON
C
C**********
C*
C 1)  FROM A SEQUENCE OF MONTHLY kPAR VALUES, CREATE A
C      CONSTANT FIELD MODEL GRID FILE SUITABLE FOR INPUT
C      TO THE HYCOM OCEAN MODEL OVER THE GIVEN REGION.
C
C     kPAR is the attenuation length scale of photosynthetically
C     available radiation (PAR), typically based on k490 from SeaWiFS.
C     Rochford P.A., A.B. Kara, A.J. Wallcraft and R.A. Arnone, 2001:
C     Importance of solar subsurface heating in ocean general
C     circulation models.  J. Geophys. Res., 106, 30923-30938.
C
C     THIS PROGRAM CAN BE USED FOR ANY SINGLE FIELD BY SPECIFYING CNAME.
C
C 2)  PARAMETERS:
C
C     MODEL GRID SPECIFICATION (W.R.T. PRESSURE GRID):
C
C        IDM    = 1ST DIMENSION OF MAJOR (HYCOM) MODEL ARRAYS
C        JDM    = 2ND DIMENSION OF MAJOR (HYCOM) MODEL ARRAYS
C
C 3)  NAMELIST INPUT:
C
C     /AFTITL/
C        CTITLE - ONE (40-CHARACTER) LINE TITLE.
C        CNAME  - ONE  (8-CHARACTER) LINE NAME (default "    kpar").
C
C     /AFTIME/
C        FINC   - TIME INCREMENT BETWEEN OUTPUT FLUXES     (DAYS)
C        FSTART - TIME OF HEAT FLUX START                  (DAYS)
C        WSTART - TIME OF WIND START, IGNORED HERE         (DAYS)
C        TMAX   - TIME OF END   OF CURRENT INTEGRATION     (DAYS)
C        TSTART - TIME OF START OF CURRENT INTEGRATION     (DAYS)
C
C     /AFCNST/
C        FMON   - MONTHY FIELD (KPAR) VALUES
C
C     NAMELIST /AFTIME/ IS PATTERNED AFTER /XXTIME/ SO THAT THE
C      MODEL''S STANDARD AWK-BASED RUN SCRIPT CUSTOMIZER CAN ALSO
C      WORK FOR THE FLUX GENERATION SCRIPT.  IN PARTICULAR, 'WSTART'
C      IS READ IN, BUT NOT USED.
C
C 4)  THE OUTPUT FIELDS HAVE THEIR COMPONENTS ON EVERY GRID POINT OF
C      THE MODEL'S 'P' GRID.  ARRAY SIZE IS 'IDM' BY 'JDM, AND THE DATA
C      IS OUTPUT .a/.b FORMAT TOGETHER WITH day AND span.
C*
C**********
C
C
      INTEGER    MAXREC
      PARAMETER (MAXREC=90000)
C
      CHARACTER*80 CLINE
      INTEGER IFREC,IUREC,IWIX,NREC
      REAL*4  WDAY(MAXREC+1),FDY,WYR
C
      INTEGER K0,K1,K2,K3
      REAL*4  W0,W1,W2,W3
C
      INTEGER I,J,KREC
      REAL*4  XMIN,XMAX
C
C --- MODEL ARRAYS.
C
      CALL XCSPMD  !define idm,jdm
      ALLOCATE(  MSK(IDM,JDM) )
      ALLOCATE(  FLD(IDM,JDM) )
C
C     NAMELIST INPUT.
C
      CALL ZHOPEN(6, 'FORMATTED', 'UNKNOWN', 0)
C
      CTITLE = ' '
      CNAME  = '    kpar'
      WRITE(6,*) 'READING /AFTITL/'
      CALL ZHFLSH(6)
      READ( 5,AFTITL)
      WRITE(6,AFTITL)
C
      FSTART = 0.0
      WSTART = 0.0
      TSTART = 0.0
      TMAX   = 0.0
      WRITE(6,*) 'READING /AFTIME/'
      CALL ZHFLSH(6)
      READ( 5,AFTIME)
      WRITE(6,AFTIME)
      WRITE(6,*)
      CALL ZHFLSH(6)
      IF     (FINC.EQ.0.0) THEN
        WRITE(6,*) 'ERROR - FINC MUST BE POSITIVE'
        WRITE(6,*)
        CALL ZHFLSH(6)
        STOP
      ENDIF
C
      FMON(:) = 0.0
      WRITE(6,*) 'READING /AFCNST/'
      CALL ZHFLSH(6)
      READ( 5,AFCNST)
      WRITE(6,AFCNST)
      WRITE(6,*)
      CALL ZHFLSH(6)
C
C     INITIALIZE HYCOM OUTPUT.
C
      CALL ZAIOST
      CALL ZAIOPN('NEW', 10)
C
      CALL ZHOPEN(10, 'FORMATTED', 'NEW', 0)
C
      PREAMBL(1) = CTITLE
      PREAMBL(2) = ' '
      PREAMBL(3) = ' '
      PREAMBL(4) = ' '
      WRITE(PREAMBL(5),'(A,2I5)')
     +        'i/jdm =',
     +       IDM,JDM
      WRITE(10,4101) PREAMBL
      WRITE(6,*)
      WRITE(6, 4101) PREAMBL
      WRITE(6,*)
C
C     PROCESS ALL THE FLUX RECORDS.
C
      NREC = NINT( (TMAX - TSTART) / FINC ) + 1
C
      WDAY(1) = FSTART
      DO 810 KREC= 1,NREC
C
C       SPECIFY THE FLUX DAY.
C
        WDAY(KREC+1) = FSTART + KREC*FINC
        CALL FCOEFS(K0,K1,K2,K3,W0,W1,W2,W3, WDAY(KREC))
C
C       CONSTANT FIELDS.
C
        DO J= 1,JDM
          DO I= 1,IDM
            FLD(I,J) = W0*FMON(K0) + W1*FMON(K1) +
     +                 W2*FMON(K2) + W3*FMON(K3)
          ENDDO
        ENDDO
C
C       WRITE OUT HYCOM FLUXS.
C
        CALL ZAIOWR(FLD,MSK,.FALSE., XMIN,XMAX, 10, .FALSE.)
        WRITE(10,4112) CNAME,WDAY(KREC),WDAY(KREC+1)-WDAY(KREC),
     +                 XMIN,XMAX
        CALL ZHFLSH(10)
C
        CALL WNDAY(WDAY(KREC), WYR,FDY)
        WRITE(6,6350) KREC,WDAY(KREC),FDY,NINT(WYR)
        CALL ZHFLSH(6)
  810 CONTINUE
C
      CALL ZAIOCL(10)
      CLOSE( UNIT=10)
      STOP
C
 4101 FORMAT(A79)
 4112 FORMAT(A,': day,span,range =',F12.5,F10.6,1P2E16.7)
 6350 FORMAT(10X,'WRITING RECORD',I5,
     +           '    FDAY =',F10.3,
     +            '  FDATE =',F8.3,'/',I4 /)
C     END OF PROGRAM KPHF_CONST.
      END
      SUBROUTINE WNDAY(WDAY, YEAR,DAY)
      IMPLICIT NONE
      REAL*4 WDAY,YEAR,DAY
C
C**********
C*
C  1) CONVERT 'WIND DAY' INTO JULIAN DAY AND YEAR.
C
C  2) THE 'WIND DAY' IS THE NUMBER OF DAYS SINCE 001/1901 (WHICH IS
C      WIND DAY 1.0).
C     FOR EXAMPLE:
C      A) YEAR=1901.0 AND DAY=1.0, REPRESENTS 0000Z HRS ON 001/1901
C         SO WDAY WOULD BE 1.0.
C      B) YEAR=1901.0 AND DAY=2.5, REPRESENTS 1200Z HRS ON 002/1901
C         SO WDAY WOULD BE 2.5.
C     YEAR MUST BE NO LESS THAN 1901.0, AND NO GREATER THAN 2099.0.
C     NOTE THAT YEAR 2000 IS A LEAP YEAR (BUT 1900 AND 2100 ARE NOT).
C
C  3) ALAN J. WALLCRAFT, PLANNING SYSTEMS INC., FEBRUARY 1993.
C*
C**********
C
      INTEGER IYR,NLEAP
      REAL*4  WDAY1
C
C     FIND THE RIGHT YEAR.
C
      IYR   = (WDAY-1.0)/365.25
      NLEAP = IYR/4
      WDAY1 = 365.0*IYR + NLEAP + 1.0
      DAY   = WDAY - WDAY1 + 1.0
      IF     (WDAY1.GT.WDAY) THEN
        IYR   = IYR - 1
      ELSEIF (DAY.GE.367.0) THEN
        IYR   = IYR + 1
      ELSEIF (DAY.GE.366.0 .AND. MOD(IYR,4).NE.3) THEN
        IYR   = IYR + 1
      ENDIF
      NLEAP = IYR/4
      WDAY1 = 365.0*IYR + NLEAP + 1.0
C
C     RETURN YEAR AND JULIAN DAY.
C
      YEAR = 1901 + IYR
      DAY  = WDAY - WDAY1 + 1.0
      RETURN
C     END OF WNDAY.
      END
      SUBROUTINE FCOEFS(K0,K1,K2,K3,W0,W1,W2,W3, FDAY)
      IMPLICIT NONE
C
      INTEGER K0,K1,K2,K3
      REAL*4  W0,W1,W2,W3, FDAY
C
C     FIND THE MONTHLY INTERPOLATION COEFFICENTS FOR A GIVEN FLUX DAY.
C
      REAL*4     ONE,TWELVE,FIFTEEN
      PARAMETER (ONE=1.0, TWELVE=12.0, FIFTEEN=15.0)
C
      REAL*4 FYR,FDY,YEAR,X,X1
C
      CALL WNDAY(FDAY, FYR,FDY)
      IF     (MOD(NINT(FYR),4).EQ.0) THEN
        YEAR = 366.0
      ELSE
        YEAR = 365.0
      ENDIF
C
      X  = 1.0+MOD(FDY+YEAR-FIFTEEN,YEAR)/(YEAR/TWELVE)
      K1 = X
      K0 = MOD(K1+10,12)+1
      K2 = MOD(K1,   12)+1
      K3 = MOD(K2,   12)+1
C
      X  = MOD(X,ONE)
      X1 = 1.-X
      W1 = X1*(1.+X *(1.-1.5*X ))
      W2 = X *(1.+X1*(1.-1.5*X1))
      W0 = -.5*X *X1*X1
      W3 = -.5*X1*X *X
C
*     WRITE(6,6000) FDAY,FDY,K0,K1,K2,K3,W0,W1,W2,W3
*     CALL ZHFLSH(6)
      RETURN
 6000 FORMAT('FCOEFS:',F9.2,F7.2,4I3,4F7.3)
      END


      program wateradd

c***********************************************************************
c
c     DL_POLY utility
c
c     Program to add SPC water molecules to a structure to fill
c     out the MD cell.
c     Assumes atomic postions are in a form compatible
c     with the CONFIG file used in DL_POLY with periodic boundary
c     conditions.
c     Water is added from 'water.300K' file
c
c     input file = CONFIG
c     output file = CONFIG.plusH2O
c
c     copyright daresbury laboratory 1993
c     author -     t.  forester  feb 1993
c
c***********************************************************************

      implicit real*8(a-h,o-z)
      parameter(mxatm = 100000)
      parameter(mxcell= 1000000)

      character*80 rdline
      character*8 name(mxatm)
      dimension cell(9),rcell(9)
      dimension xxx(mxatm),yyy(mxatm),zzz(mxatm)
      dimension ssx(mxatm),ssy(mxatm),ssz(mxatm)
      dimension ox(256),oy(256),oz(256)
      dimension h1x(256),h1y(256),h1z(256)
      dimension h2x(256),h2y(256),h2z(256)
      dimension nix(27),niy(27),niz(27)
      dimension lstrem(mxatm)
      dimension xd(mxatm),yd(mxatm),zd(mxatm)

      dimension lct(mxcell),link(mxatm)

      data nix/  0, 1, 0, 0,-1, 1, 0,-1, 1, 0,-1, 1,-1, 1,
     x   -1, 0, 0, 1,-1, 0, 1,-1, 0, 1,-1, 1,-1/
      data niy/  0, 0, 1, 0, 1, 1,-1, 0, 0, 1,-1,-1, 1, 1,
     x    0,-1, 0,-1,-1, 1, 0, 0,-1, 1, 1,-1,-1/
      data niz/  0, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1,
     x    0, 0,-1, 0, 0,-1,-1,-1,-1,-1,-1,-1,-1/

c
c     tolerance for O - solute distance

      write(*,*) 'minimum Ow-solute distance ? '
      read(*,*) tolnce
      tolnce= tolnce**2

c
c     tolerance for water site- water site distance

      write(*,*)'minimum Ow/Hw - Ow/Hw distance ? '
      read(*,*) tolow
      tolow=tolow**2
c
c     device identities

      iwt = 7
      ird = 8
      iwr = 9

      open(iwt,file='water.300K')
      open(ird,file='CONFIG')
      open(iwr,file='CONFIG.plusH2O')

      read(ird,'(a80)') rdline
      write(iwr,'(a80)') rdline

      read(ird,'(2i10)') levcfg,imcon
      if(imcon.eq.0) call error(50)

      read(ird,'(3f20.8)') cell
c
c     imcon = 10 for ellipsoidal boundary

      if(imcon.ne.10) then
        write(iwr,'(2i10)') 0,imcon
        write(iwr,'(3f20.8)') cell
      else
        write(iwr,'(2i10)') 0,0
      endif

      do i = 1,mxatm

        read(ird,'(a8)',end=100) name(i)
        read(ird,'(3f20.8)',end=100) xxx(i),yyy(i),zzz(i)
        if(levcfg.gt.0) read(ird,*,end=100)
        if(levcfg.gt.1) read(ird,*,end=100)

      enddo

  100 natm = i-1

      call invert(cell,rcell,det)

      imcon1=imcon
      imcon = min(imcon,3)
c
c     place solute atoms into link list

      call cells
     x   (natm,ncells,imcon,tolnce,xdc,ydc,zdc,
     x   lct,link,cell,rcell,ssx,ssy,ssz,xxx,yyy,zzz)
c
c     read in data from water300K - equilibrated water

      read(iwt,*)
      read(iwt,*) axcub, naa

      do i = 1,naa

        read(iwt,*)
        read(iwt,*) ox(i),oy(i),oz(i)
        read(iwt,*)
        read(iwt,*) h1x(i),h1y(i),h1z(i)
        read(iwt,*)
        read(iwt,*) h2x(i),h2y(i),h2z(i)
      enddo
c
c     define number of water blocks to use

      imax=int((abs(cell(1))+abs(cell(4))+abs(cell(7)))/axcub+.99d0)/2+1
      jmax=int((abs(cell(2))+abs(cell(5))+abs(cell(8)))/axcub+.99d0)/2+1
      kmax=int((abs(cell(3))+abs(cell(6))+abs(cell(9)))/axcub+.99d0)/2+1

c
c     inverse of MD cell

      call invert(cell,rcell,det)

      write(*,*) 'inserting water '
      write(*,*)

      iplus = 0
      nsbcll=27
      call spcins
     x   (name,h1x,h1y,h1z,h2x,h2y,h2z,ox,oy,oz,iplus,imax,jmax,kmax,
     x   naa,natm,nsbcll,mxatm,axcub,tolnce,xdc,ydc,zdc,lct,link,
     x   nix,niy,niz,xxx,yyy,zzz,ssx,ssy,ssz,cell,rcell)

c
c     check for bad interactions (less than tolow apart)

      natm1 = natm+3*(iplus)
      tolnce = max(tolow,9.d0)

c
c     place all atoms in link cells

      call cells
     x   (natm1,ncells,imcon,tolnce,xdc,ydc,zdc,
     x   lct,link,cell,rcell,ssx,ssy,ssz,xxx,yyy,zzz)

      tolnce = tolow
c
c     additional checks on non standard periodic boundaries

      if(imcon1.gt.3.and.imcon1.ne.6) then

        imcon = imcon1
        call imgchk
     x     (imcon,natm,iplus,tolnce,lstrem,
     x     ssx,ssy,ssz,xxx,yyy,zzz,cell,xd,yd,zd)

      else

        call spcchk
     x     (iplus,ncells,natm,14,tolnce,xdc,ydc,zdc,lct,
     x     link,lstrem,nix,niy,niz,ssx,ssy,ssz,xxx,yyy,zzz,cell)

      endif

c
c     write out final structure

      do i = 1,natm+3*iplus

        write(iwr,'(a8,i10)') name(i),i
        write(iwr,'(3f20.8)') xxx(i),yyy(i),zzz(i)
      enddo

      write(*,*)
      write(*,*) 'all done: added ',iplus,' waters'
      write(*,*) 'output in CONFIG.plusH2O'

      end

      subroutine images
     x     (imcon,idnode,mxnode,natm,cell,xxx,yyy,zzz)

c
c***********************************************************************
c
c     dl_poly subroutine for calculating the minimum image
c     of atom pairs within a specified MD cell
c
c     parallel replicated data version
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith march 1992.
c
c     for
c     imcon=0 no boundary conditions apply
c     imcon=1 standard cubic boundaries apply
c     imcon=2 rectangular (slab) boundaries apply
c     imcon=3 parallelepiped boundaries apply
c     imcon=4 truncated octahedron boundaries apply
c     imcon=5 rhombic dodecahedron boundaries apply
c     imcon=6 x-y parallelogram, z non-periodic
c
c     note: in all cases the centre of the cell is at (0,0,0)
c     warning - replicated data version: does not re-merge
c     coordinate arrays
c
c***********************************************************************
c

      implicit real*8 (a-h,o-z)

      dimension xxx(*),yyy(*),zzz(*)
      dimension cell(9),rcell(9)

      if(imcon.eq.1)then
c
c     standard cubic boundary conditions

         aaa=1.d0/cell(1)

         do i=idnode+1,natm,mxnode

            xxx(i)=xxx(i)-cell(1)*nint(aaa*xxx(i))
            yyy(i)=yyy(i)-cell(1)*nint(aaa*yyy(i))
            zzz(i)=zzz(i)-cell(1)*nint(aaa*zzz(i))

         enddo

      else if(imcon.eq.2)then
c
c     rectangular (slab) boundary conditions

         aaa=1.d0/cell(1)
         bbb=1.d0/cell(5)
         ccc=1.d0/cell(9)

         do i=idnode+1,natm,mxnode

           xxx(i)=xxx(i)-cell(1)*nint(aaa*xxx(i))
           yyy(i)=yyy(i)-cell(5)*nint(bbb*yyy(i))
           zzz(i)=zzz(i)-cell(9)*nint(ccc*zzz(i))

         enddo

      else if(imcon.eq.3)then
c
c     parallelepiped boundary conditions

         call invert(cell,rcell,det)
         if(abs(det).lt.1.d-6)call error(120)

         do i=idnode+1,natm,mxnode

            ssx=(rcell(1)*xxx(i)+rcell(4)*yyy(i)+rcell(7)*zzz(i))
            ssy=(rcell(2)*xxx(i)+rcell(5)*yyy(i)+rcell(8)*zzz(i))
            ssz=(rcell(3)*xxx(i)+rcell(6)*yyy(i)+rcell(9)*zzz(i))

            xss=ssx-nint(ssx)
            yss=ssy-nint(ssy)
            zss=ssz-nint(ssz)

            xxx(i)=(cell(1)*xss+cell(4)*yss+cell(7)*zss)
            yyy(i)=(cell(2)*xss+cell(5)*yss+cell(8)*zss)
            zzz(i)=(cell(3)*xss+cell(6)*yss+cell(9)*zss)

         enddo

      else if(imcon.eq.4)then
c
c     truncated octahedral boundary conditions

         if(.not.(abs(cell(1)-cell(5)).lt.1.d-3.and.
     x      abs(cell(5)-cell(9)).lt.1.d-3)) call error(120)

         aaa=1.d0/cell(1)

         do i=idnode+1,natm,mxnode

            xxx(i)=xxx(i)-cell(1)*nint(aaa*xxx(i))
            yyy(i)=yyy(i)-cell(1)*nint(aaa*yyy(i))
            zzz(i)=zzz(i)-cell(1)*nint(aaa*zzz(i))

            if((abs(xxx(i))+abs(yyy(i))+abs(zzz(i))).ge.
     x           (0.75d0*cell(1)))then

               xxx(i)=xxx(i)-0.5d0*sign(cell(1),xxx(i))
               yyy(i)=yyy(i)-0.5d0*sign(cell(1),yyy(i))
               zzz(i)=zzz(i)-0.5d0*sign(cell(1),zzz(i))

            endif

         enddo

      else if(imcon.eq.5)then
c
c     rhombic dodecahedral boundary conditions

         rt2=sqrt(2.d0)
         if(abs(cell(1)-cell(5)).gt.1.d-3.or.
     x      abs(cell(9)-cell(1)*rt2).gt.1.d-3)
     x      call error(120)

         aaa=1.d0/cell(1)
         bbb=1.d0/cell(9)

         do i=idnode+1,natm,mxnode

           ssx= xxx(i)*aaa
           ssy= yyy(i)*aaa
           ssz= zzz(i)*bbb

           ssx = ssx-nint(ssx)
           ssy = ssy-nint(ssy)
           ssz = ssz-nint(ssz)

           if(abs(ssx)+abs(ssy)+2.d0*abs(ssz).gt.1.d0) then

             ssx = ssx - sign(0.5d0,ssx)
             ssy = ssy - sign(0.5d0,ssy)
             ssz = ssz - sign(0.5d0,ssz)

           endif

           xxx(i) = ssx*cell(1)
           yyy(i) = ssy*cell(1)
           zzz(i) = ssz*cell(9)

         enddo

       else if(imcon.eq.6)then
c
c     parallelogram in x-y, z non periodic

         call invert(cell,rcell,det)
         if(abs(det).lt.1.d-6)call error(120)

         do i=idnode+1,natm,mxnode

            ssx=(rcell(1)*xxx(i)+rcell(4)*yyy(i)+rcell(7)*zzz(i))
            ssy=(rcell(2)*xxx(i)+rcell(5)*yyy(i)+rcell(8)*zzz(i))

            xss=ssx-nint(ssx)
            yss=ssy-nint(ssy)

            xxx(i)=(cell(1)*xss+cell(4)*yss+cell(7)*zss)
            yyy(i)=(cell(2)*xss+cell(5)*yss+cell(8)*zss)

         enddo

      endif

      return
      end

      subroutine invert(a,b,d)
c
c***********************************************************************
c
c     dl_poly subroutine to invert a 3 * 3 matrix using cofactors
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith april 1992.
c
c***********************************************************************
c

      real*8 a,b,d,r

      dimension a(9),b(9)
c
c     calculate adjoint matrix
      b(1)=a(5)*a(9)-a(6)*a(8)
      b(2)=a(3)*a(8)-a(2)*a(9)
      b(3)=a(2)*a(6)-a(3)*a(5)
      b(4)=a(6)*a(7)-a(4)*a(9)
      b(5)=a(1)*a(9)-a(3)*a(7)
      b(6)=a(3)*a(4)-a(1)*a(6)
      b(7)=a(4)*a(8)-a(5)*a(7)
      b(8)=a(2)*a(7)-a(1)*a(8)
      b(9)=a(1)*a(5)-a(2)*a(4)
c
c     calculate determinant
      d=a(1)*b(1)+a(4)*b(2)+a(7)*b(3)
      r=0.d0
      if(abs(d).gt.0.d0)r=1.d0/d
c
c     complete inverse matrix
      b(1)=r*b(1)
      b(2)=r*b(2)
      b(3)=r*b(3)
      b(4)=r*b(4)
      b(5)=r*b(5)
      b(6)=r*b(6)
      b(7)=r*b(7)
      b(8)=r*b(8)
      b(9)=r*b(9)
      return
      end

      subroutine error(kode)

c***********************************************************************
c
c     dl_poly subroutine
c
c     copyright - daresbury laboratory
c     author    - t. forester
c
c***********************************************************************

      implicit real*8(a-h,o-z)

      write(*,*)
      if(kode.eq.50) then
        write(*,*) ' error - invalid image convention'
      elseif(kode.eq.60) then
        write(*,*) ' error : system volume too small'
      elseif(kode.eq.100) then
        write(*,*) ' error : system too large for link cells'
      elseif(kode.eq.110) then
        write(*,*) ' error : system too small for link cells'
      elseif(kode.eq.120) then
        write(*,*) ' error : invalid cell vectors '
      elseif(kode.eq.200) then
        write(*,*) ' too many atoms in system: increase parameter mxatm'
      else
        write(*,*) ' unnamed error found'
      endif

      if(kode.gt.0) stop

      return
      end

      subroutine cells
     x   (natm,ncells,imcon,tolnce,xdc,ydc,zdc,
     x   lct,link,cell,rcell,ssx,ssy,ssz,xxx,yyy,zzz)

c***********************************************************************
c
c     dl_poly subroutine
c
c     copyright - daresbury laboratory
c     author    - t. forester
c
c***********************************************************************

      implicit real*8(a-h,o-z)
      parameter(mxcell=1000000)

      logical linc

      dimension lct(*),link(*)
      dimension ssx(*),ssy(*),ssz(*)
      dimension cell(*),rcell(*),celprp(10)
      dimension xxx(*),yyy(*),zzz(*)

      call dcell(cell,celprp)
      if(celprp(10).lt.1.d0) call error(60)

      rlink = sqrt(tolnce)
      ilx = int(celprp(7)/rlink)
      ily = int(celprp(8)/rlink)
      ilz = int(celprp(9)/rlink)

      ncells = ilx*ily*ilz
c
c     check for enough link cells

      if(ncells.gt.mxcell) call error(100)
c
c     check system is big enough

      linc =.false.
      if(ilx.lt.3) linc = .true.
      if(ily.lt.3) linc = .true.
      if(ilz.lt.3) linc = .true.

      if(linc) call error(110)

c
c     calculate link cell indices

      do i = 1,ncells

        lct(i)=0

      enddo
c
c     link-cell cutoff for reduced space

      xdc = dble(ilx)
      ydc = dble(ily)
      zdc = dble(ilz)

c
c     reduced space coordinates

      call images(imcon,0,1,natm,cell,xxx,yyy,zzz)

      do i = 1,natm

        ssx(i)=(rcell(1)*xxx(i)+rcell(4)*yyy(i)+rcell(7)*zzz(i))+0.5d0
        ssy(i)=(rcell(2)*xxx(i)+rcell(5)*yyy(i)+rcell(8)*zzz(i))+0.5d0
        ssz(i)=(rcell(3)*xxx(i)+rcell(6)*yyy(i)+rcell(9)*zzz(i))+0.5d0

      enddo
c
c     link neighbours

      do i = 1,natm

        ix = int(xdc*ssx(i))
        iy = int(ydc*ssy(i))
        iz = int(zdc*ssz(i))

        icell = 1+ix+ilx*(iy+ily*iz)

        j = lct(icell)
        lct(icell)=i
        link(i)=j

      enddo

      return
      end

      subroutine lnkimg(jy,ily,cy)

c***********************************************************************
c
c     dl_poly subroutine
c
c     copyright - daresbury laboratory
c     author    - t. forester
c
c***********************************************************************

      implicit real*8(a-h,o-z)

      if(jy.ge.ily) then

        jy = jy-ily
        cy = 1.d0

      elseif(jy.lt.0) then

        jy = jy+ily
        cy =-1.d0

      endif

      return
      end

      subroutine spcins
     x   (name,h1x,h1y,h1z,h2x,h2y,h2z,ox,oy,oz,iplus,imax,jmax,kmax,
     x   naa,natm,nsbcll,mxatm,axcub,tolnce,xdc,ydc,zdc,lct,link,
     x   nix,niy,niz,xxx,yyy,zzz,ssx,ssy,ssz,cell,rcell)

c***********************************************************************
c
c     dl_poly subroutine
c
c     copyright - daresbury laboratory
c     author    - t. forester
c
c***********************************************************************

      implicit real*8(a-h,o-z)

      logical ladd

      character*8 ow,hw,name(*)
      dimension lct(*),link(*)
      dimension ssx(*),ssy(*),ssz(*)
      dimension xxx(*),yyy(*),zzz(*)
      dimension h1x(*),h1y(*),h1z(*)
      dimension h2x(*),h2y(*),h2z(*)
      dimension ox(*),oy(*),oz(*)
      dimension nix(*),niy(*),niz(*)
      dimension cell(*),rcell(*)

      data ow/'OW      '/,hw/'HW      '/

      ilx=int(xdc+0.5d0)
      ily=int(ydc+0.5d0)
      ilz=int(zdc+0.5d0)

      do i = -imax,imax

        xi = dble(i)*axcub

        do j = -jmax,jmax

          yi = dble(j)*axcub

          do k = -kmax,kmax

            zi = dble(k)*axcub

            do l = 1,naa

              xo = xi + ox(l)
              yo = yi + oy(l)
              zo = zi + oz(l)
c
c     check if water is in basic MD cell

              sx=(rcell(1)*xo+rcell(4)*yo+rcell(7)*zo)
              sy=(rcell(2)*xo+rcell(5)*yo+rcell(8)*zo)
              sz=(rcell(3)*xo+rcell(6)*yo+rcell(9)*zo)

              if(abs(sx).le..5d0) then
                if(abs(sy).le..5d0) then
                  if(abs(sz).le..5d0)then
c
c     compute link cell index

                    sx=sx+0.5d0
                    sy=sy+0.5d0
                    sz=sz+0.5d0

                    ix = int(xdc*sx)
                    iy = int(ydc*sy)
                    iz = int(zdc*sz)
c
c     flag to add water

                    ladd = .true.
c
c     loop over nearby link cells of solute

                    nsbcll = 27
                    do kc = 1,nsbcll

                      cx = 0.d0
                      cy = 0.d0
                      cz = 0.d0

                      jx=ix+nix(kc)
                      jy=iy+niy(kc)
                      jz=iz+niz(kc)
c
c     minimum image convention for link cells

                      call lnkimg(jx,ilx,cx)
                      call lnkimg(jy,ily,cy)
                      call lnkimg(jz,ilz,cz)
c
c     index of neighbouring cell

                      jc = 1+jx+ilx*(jy+ily*jz)
                      jj=lct(jc)
c
c     ignore if empty

                      if(jj.gt.0) then

  300                   continue

c
c     distance in real space : minimum image applied

                        sxd = ssx(jj)-sx+cx
                        syd = ssy(jj)-sy+cy
                        szd = ssz(jj)-sz+cz

                        xd=cell(1)*sxd+cell(4)*syd+cell(7)*szd
                        yd=cell(2)*sxd+cell(5)*syd+cell(8)*szd
                        zd=cell(3)*sxd+cell(6)*syd+cell(9)*szd

                        rsq = xd*xd+yd*yd+zd*zd
c
c     test of distance
                        if(rsq.lt.tolnce) then
                          ladd =.false.
                        endif

                        jj=link(jj)
                        if(jj.gt.0) goto 300

                      endif

                    enddo
c
c     add O to structure

                    if(ladd) then

                      iplus = iplus + 1
                      k1 = natm+(iplus-1)*3+1
                      if(k1+2.gt.mxatm) call error(200)

                      xxx(k1) = xo
                      yyy(k1) = yo
                      zzz(k1) = zo
                      name(k1) = ow

                      k2 = k1 + 1
                      name(k2) = hw
                      xxx(k2) = xi + h1x(l)
                      yyy(k2) = yi + h1y(l)
                      zzz(k2) = zi + h1z(l)

                      k3 = k1 + 2
                      name(k3) = hw
                      xxx(k3) = xi + h2x(l)
                      yyy(k3) = yi + h2y(l)
                      zzz(k3) = zi + h2z(l)

                    endif

                  endif
                endif
              endif

            enddo

          enddo

        enddo

      enddo

      return
      end

      subroutine spcchk
     x     (iplus,ncells,natm,nsbcll,tolnce,xdc,ydc,zdc,lct,
     x     link,lstrem,nix,niy,niz,ssx,ssy,ssz,xxx,yyy,zzz,cell)

c***********************************************************************
c
c     dl_poly subroutine
c
c     copyright - daresbury laboratory
c     author    - t. forester
c
c***********************************************************************

      implicit real*8(a-h,o-z)

      dimension lct(*),link(*)
      dimension ssx(*),ssy(*),ssz(*)
      dimension xxx(*),yyy(*),zzz(*)
      dimension nix(*),niy(*),niz(*)
      dimension cell(*)
      dimension lstrem(*)

      ilx = int(xdc+0.5d0)
      ily = int(ydc+0.5d0)
      ilz = int(zdc+0.5d0)

      ix=0
      iy=0
      iz=0

      irem =0

      do ic = 1,ncells

        ii=lct(ic)
        if(ii.gt.0) then
c
c     secondary loop over subcells

          do kc = 1,nsbcll

            ii = lct(ic)

            cx = 0.d0
            cy = 0.d0
            cz = 0.d0

            jx=ix+nix(kc)
            jy=iy+niy(kc)
            jz=iz+niz(kc)

c
c     minimum image convention for link cells

            call lnkimg(jx,ilx,cx)
            call lnkimg(jy,ily,cy)
            call lnkimg(jz,ilz,cz)
c
c     index of neighbouring cell

            jc =1+jx+ilx*(jy+ily*jz)
            jj=lct(jc)

c
c     ignore if empty of water

            if(jj.gt.0) then

  200        continue
c
c     water molecule id for site ii

              ik = (ii-natm-1)/3 +1

              if(ic.eq.jc) jj=link(ii)
              if(jj.gt.0) then

  300           continue

c
c     distance in real space : minimum image applied

                sxd = ssx(jj)-ssx(ii)+cx
                syd = ssy(jj)-ssy(ii)+cy
                szd = ssz(jj)-ssz(ii)+cz

                xd=cell(1)*sxd+cell(4)*syd+cell(7)*szd
                yd=cell(2)*sxd+cell(5)*syd+cell(8)*szd
                zd=cell(3)*sxd+cell(6)*syd+cell(9)*szd

                rsq = xd*xd + yd*yd + zd*zd

c
c     test of distance

                if(rsq.lt.tolnce) then
c
c     make sure sites are not on same water molecule!

                  jk = (jj-natm-1)/3 +1

                  if(ik.gt.0) then
                    if(jk.gt.0) then
                      if(ik.ne.jk) then

                        irem = irem+1
                        lstrem(irem) = max(ik,jk)

                      endif
                    endif
                  endif

                endif

                jj=link(jj)
                if(jj.gt.natm) goto 300

              endif

              jj=lct(jc)
              ii=link(ii)

              if(ii.gt.natm) goto 200

            endif

          enddo

        endif

        ix=ix+1
        if(ix.ge.ilx) then

          ix=0
          iy=iy+1

          if(iy.ge.ily) then

            iy=0
            iz=iz+1

          endif

        endif

      enddo
c
c     remove unwanted water molecules

      call cleanup(natm,iplus,irem,lstrem,xxx,yyy,zzz)

      return
      end

      subroutine shellsort(n,list)

c***********************************************************************
c
c     dlpoly shell sort routine.
c     Sorts an array of integers into ascending order
c
c     copyright daresbury laboratory 1993
c     author - t.forester   november 1993
c
c***********************************************************************

      implicit real*8(a-h,o-z)

      dimension list(*)

c
c     set up sort

      if(n.gt.1) then

c     number of lists
         nl = n/2

c     iterate shell sort

   10  do nn = 1,nl
c
c     begin insertion sort on nnth list

            do i = nn+nl,n,nl

               imax = list(i)
               ix = i
c
c     find location for insertion

               j = i
  100          j = j-nl

               if(j.lt.1) goto 110

               if (list(j).gt.imax) then

                  ix = j

               else

                  j =1

               endif

               goto 100
  110           continue

c
c     insert in index array

               do j = i,ix+nl,-nl

                  list(j) = list(j-nl)

               enddo

               list(ix) = imax

            enddo

         enddo

         nl = nl/2
         if(nl.gt.0) goto 10

      endif

      return
      end

      subroutine dcell(aaa,bbb)

c
c***********************************************************************
c
c     dl_poly subroutine to calculate the dimensional properies of
c     a simulation cell specified by the input matrix aaa.
c     the results are returned in the array bbb, with :
c
c     bbb(1 to 3) - lengths of cell vectors
c     bbb(4 to 6) - cosines of cell angles
c     bbb(7 to 9) - perpendicular cell widths
c     bbb(10)     - cell volume
c
c     copyright daresbury laboratory 1992
c     author - w. smith         july 1992
c
c***********************************************************************
c

      implicit real*8 (a-h,o-z)

      dimension aaa(9),bbb(10)
c
c     calculate lengths of cell vectors

      bbb(1)=sqrt(aaa(1)*aaa(1)+aaa(2)*aaa(2)+aaa(3)*aaa(3))
      bbb(2)=sqrt(aaa(4)*aaa(4)+aaa(5)*aaa(5)+aaa(6)*aaa(6))
      bbb(3)=sqrt(aaa(7)*aaa(7)+aaa(8)*aaa(8)+aaa(9)*aaa(9))
c
c     calculate cosines of cell angles

      bbb(4)=(aaa(1)*aaa(4)+aaa(2)*aaa(5)+aaa(3)*aaa(6))/(bbb(1)*bbb(2))
      bbb(5)=(aaa(1)*aaa(7)+aaa(2)*aaa(8)+aaa(3)*aaa(9))/(bbb(1)*bbb(3))
      bbb(6)=(aaa(4)*aaa(7)+aaa(5)*aaa(8)+aaa(6)*aaa(9))/(bbb(2)*bbb(3))
c
c     calculate vector products of cell vectors

      axb1=aaa(2)*aaa(6)-aaa(3)*aaa(5)
      axb2=aaa(3)*aaa(4)-aaa(1)*aaa(6)
      axb3=aaa(1)*aaa(5)-aaa(2)*aaa(4)
      bxc1=aaa(5)*aaa(9)-aaa(6)*aaa(8)
      bxc2=aaa(6)*aaa(7)-aaa(4)*aaa(9)
      bxc3=aaa(4)*aaa(8)-aaa(5)*aaa(7)
      cxa1=aaa(8)*aaa(3)-aaa(2)*aaa(9)
      cxa2=aaa(1)*aaa(9)-aaa(3)*aaa(7)
      cxa3=aaa(2)*aaa(7)-aaa(1)*aaa(8)
c
c     calculate volume of cell

      bbb(10)=abs(aaa(1)*bxc1+aaa(2)*bxc2+aaa(3)*bxc3)
c
c     calculate cell perpendicular widths

      bbb(7)=bbb(10)/sqrt(bxc1*bxc1+bxc2*bxc2+bxc3*bxc3)
      bbb(8)=bbb(10)/sqrt(cxa1*cxa1+cxa2*cxa2+cxa3*cxa3)
      bbb(9)=bbb(10)/sqrt(axb1*axb1+axb2*axb2+axb3*axb3)

      return
      end

      subroutine  imgchk
     x     (imcon,natm,iplus,tolnce,lstrem,
     x     ssx,ssy,ssz,xxx,yyy,zzz,cell,xd,yd,zd)

c
c**********************************************************************
c
c     dlpoly utility subroutine to remove additional spc waters from
c     unusual (periodic) bondaries: TO, RD, ellipsoidal
c
c     copyright daresbury laboratory 1994
c     author      t.forester october 1994
c
c**********************************************************************
c
      implicit real*8(a-h,o-z)

      logical check

      dimension ssx(*),ssy(*),ssz(*)
      dimension xxx(*),yyy(*),zzz(*)
      dimension cell(*)
      dimension xd(*),yd(*),zd(*)
      dimension lstrem(*)

      natm1 = natm+3*iplus
      irem = 0
c
c     Truncated octahedral (TO)

      if(imcon.eq.4) then
c
c     check that Ow is in central box

        do i = natm+1,natm1-2,3

          sx = abs(ssx(i) -0.5d0)
          sy = abs(ssy(i) -0.5d0)
          sz = abs(ssz(i) -0.5d0)

          if(sx+sy+sz.gt.0.75d0) then

            irem = irem+1
            lstrem(irem) = (i-natm-1)/3 + 1

          endif

        enddo

      elseif(imcon.eq.5) then
c
c     Rhombic dodecahedral

        do i = natm+1,natm1,3

          sx = abs(ssx(i) - 0.5d0)
          sy = abs(ssy(i) - 0.5d0)
          sz = abs(ssz(i) - 0.5d0)

          if(sx+sy+2.d0*sz.gt.1.d0) then

            irem = irem+1
            lstrem(irem) = (i-natm-1)/3 + 1

          endif

        enddo

      elseif(imcon.eq.10) then
c
c     ellipsoidal shell

        do i = natm+1,natm1,3

          sx = abs(ssx(i) - 0.5d0)
          sy = abs(ssy(i) - 0.5d0)
          sz = abs(ssz(i) - 0.5d0)

          if(sx*sx+sy*sy+sz*sz.gt.0.25d0) then

            irem = irem+1
            lstrem(irem) = (i-natm-1)/3 + 1

          endif

        enddo

      endif
c
c     remove unwanted waters

      call cleanup(natm,iplus,irem,lstrem,xxx,yyy,zzz)

      natm1 = natm+3*iplus
      irem = 0

      do i = natm+1,natm1-3
c
c     water molecule number

        ik = (i-natm-1)/3 + 1

        ii = 0

        do j = i+1,natm1

          jk = (j-natm - 1)/3 + 1

          if(jk.ne.ik) then

            ii=ii+1
            xd(ii) = xxx(i)-xxx(j)
            yd(ii) = yyy(i)-yyy(j)
            zd(ii) = zzz(i)-zzz(j)

          endif

        enddo
c
c     periodic image

        call images(imcon,0,1,ii,cell,xd,yd,zd)

        check = .true.

        do j = 1,ii

          rsq = xd(j)**2+ yd(j)**2 +zd(j)**2
          if(rsq.lt.tolnce) check = .false.

        enddo

        if(.not.check) then
          irem = irem+1
          lstrem(irem) = ik
        endif

      enddo
c
c     remove unwanted waters

      call cleanup(natm,iplus,irem,lstrem,xxx,yyy,zzz)

      natm1 = natm+3*iplus

      return
      end

      subroutine  cleanup(natm,iplus,irem,lstrem,xxx,yyy,zzz)

c***********************************************************************
c
c     dl_poly subroutine
c
c     copyright - daresbury laboratory
c     author    - t. forester
c
c***********************************************************************

      implicit real*8(a-h,o-z)
      dimension xxx(*),yyy(*),zzz(*)
      dimension lstrem(*)
c
c     sort into order

      call shellsort(irem,lstrem)
c
c     remove redundancies from list

      ii = 0
      do i = irem,2,-1

        if(lstrem(i-1).eq.lstrem(i)) then

          ii=ii+1

          do jj = i,irem
            lstrem(jj)=lstrem(jj+1)
          enddo

        endif

      enddo

      irem = irem-ii
c
c     go through list and remove all the ones we don't want

      do ik = irem,1,-1

        j = natm + (lstrem(ik)-1)*3 + 1
        ntot=natm+3*(iplus)

        do i = j,ntot-3

          xxx(i) = xxx(i+3)
          yyy(i) = yyy(i+3)
          zzz(i) = zzz(i+3)

        enddo

        iplus = iplus-1

      enddo

      return
      end


!
!     ------------------------------------------------------------------
!     G S T A T E
!     ------------------------------------------------------------------
!
      SUBROUTINE GSTATE(NFIRST, NLAST)
      use inout_C
      use ndims_C
      use non30_C
      use nor_C
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:56:52  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE lval_I
      USE numval_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: NFIRST
      INTEGER , INTENT(IN) :: NLAST
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: NWD = 128
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER , DIMENSION(15) :: J1QN, J2QN, J3QN
      INTEGER :: IRD, I, N, J, K, NCOM1, NOR11, JJ, M, N1
      CHARACTER , DIMENSION(15) :: JCQN, JQNG, J3QNG
      CHARACTER , DIMENSION(2) :: LABEL*8
      CHARACTER :: LINE*72
!-----------------------------------------------
!
!      COMMON /INOUT/IREAD,IWRITE,ISCW,iuc(2),iuw(2),iul(2),iuj(2),iut(2)
!      POINTER(QNOC,NOCCSH(1)),(QNELCSH,NELCSH(8,1)),
!     :       (QNOCORB,NOCORB(8,1)),(QJ1,J1QNRD(15,1))
!      POINTER(QIAJCMP,IAJCMP(1)),(QLJCOMP,LJCOMP(1)),
!     :       (QNJCOMP,NJCOMP(1)),(QIAJCLD,IAJCLD(1)),
!     :       (QLJCLSD,LJCLSD(1))
!      COMMON /NDIMS/ QNOC,QNELCSH,QNOCORB,QJ1,NCFG
!      COMMON /NON30/ QIAJCMP,QNJCOMP,QLJCOMP,QIAJCLD,QLJCLSD,MAXORB
!      COMMON /NOR/NCOM,NCLOSI,NCLOSF,NORBI,NORBF,IWAR
      DATA LABEL/ 'INITIAL', 'FINAL'/
!
!      DATA DEFINING THE STATE IS READ IN AND PRINTED OUT.
!
    5 FORMAT(8(1X,A3,'(',I2,')'))
   55 FORMAT(8(1X,A3,1X,I2,1X))
   36 FORMAT(15(1X,A1,A1,A1))
   24 FORMAT(/,/,' INITIAL STATE CONFIGURATIONS:-')
   25 FORMAT(/,'     ',I5,'.  ',10(1X,A3,'(',I2,')'))
   26 FORMAT(11X,10(1X,4X,I1,A1,I1))
   27 FORMAT(22X,9(1X,4X,A1,A1,I1))
   28 FORMAT(' ----------------------------  '/)
   29 FORMAT(/,/,' FINAL STATE CONFIGURATIONS:-')
   30 FORMAT(2X,'ELECTRON ',A3,' NOT FOUND IN THE LIST OF ELECTRONS',&
         ' FOR THE ',A8,' STATE')
      IF (NFIRST == 1) THEN
!        WRITE(IWRITE,24)
         IRD = IUC(1)
      ELSE
!        WRITE(IWRITE,29)
         IRD = IUC(2)
      ENDIF
      WRITE (IWRITE, 28)
      DO I = NFIRST, NLAST
         READ (IRD, '(A72)') LINE
         N = 0
         J = 2
   60    CONTINUE
         IF (LINE(J:J+2)/='   ' .AND. N<8) THEN
            N = N + 1
            J = J + 8
            GO TO 60
         ENDIF
         NOCCSH(I) = N
         READ (LINE, 55) (NOCORB(J,I),NELCSH(J,I),J=1,N)
         K = I
         IF (NFIRST /= 1) K = I - NFIRST + 1
!dbg  WRITE(IWRITE,25) K,(NOCORB(J,I),NELCSH(J,I),J=1,N)
         NCOM1 = NCOM + 1
         NOR11 = NCOM1 + NORBI
         L61: DO J = 1, N
            DO JJ = 1, MAXORB
               IF (NFIRST==1 .AND. JJ>=NOR11) EXIT
               IF (NFIRST/=1 .AND. JJ>=NCOM1 .AND. JJ<NOR11) CYCLE
               IF (NOCORB(J,I) /= IAJCMP(JJ)) CYCLE
               NOCORB(J,I) = JJ
               CYCLE  L61
            END DO
!
!        ELECTRON NOT FOUND IN THE LIST
!
            WRITE (IWRITE, 30) NOCORB(J,I), LABEL(NFIRST)
            STOP
         END DO L61
         M = 2*N - 1
         N1 = N + 1
!GG      READ(IRD,6)      (J3QN(J),JCQN(J),J1QN(J),J=1,M)
         READ (IRD, 36) (J3QNG(J),JCQN(J),JQNG(J),J=1,M)
!dbg  WRITE(IWRITE,26) (J3QNG(J),JCQN(J),J1QN(J),J=1,N)
!dbg      IF(N.EQ.1) GO TO 64
!dbg  WRITE(IWRITE,27) (J3QN(J),JCQN(J),J1QN(J),J=N1,M)
!dbg   64 CONTINUE
         DO J = 1, M
            J2QN(J) = 2*LVAL(JCQN(J)) + 1
!GG
            J1QN(J) = NUMVAL(JQNG(J))
            J3QN(J) = ICHAR(J3QNG(J)) - ICHAR('1') + 1
!GG
            J1QNRD(J,I) = (J3QN(J)*64+J2QN(J))*64 + J1QN(J)
         END DO
      END DO
      RETURN
      END SUBROUTINE GSTATE


module type_RASILU0_send_comm
#include <messenger.h>
    use mod_kinds,                  only: rk, ik
    use mod_constants,              only: NFACES, DIAG, INTERIOR
    use mod_chidg_mpi,              only: ChiDG_COMM, IRANK
    use type_ivector,               only: ivector_t
    use type_mesh,                  only: mesh_t
    use type_chidg_matrix,          only: chidg_matrix_t
    use type_mpi_request_vector,    only: mpi_request_vector_t
    use type_RASILU0_send_comm_dom, only: RASILU0_send_comm_dom_t

    use mpi_f08,                    only: MPI_ISend, MPI_INTEGER4, MPI_REQUEST, &
                                          MPI_STATUSES_IGNORE
    implicit none

    !>  A container for storing information about what gets sent to a particular
    !!  neighbor processor.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/10/2016
    !!
    !!
    !!
    !-------------------------------------------------------------------------------------------
    type, public :: RASILU0_send_comm_t

        integer(ik)                                 :: proc
        type(RASILU0_send_comm_dom_t),  allocatable :: dom(:)   ! A description for each domain
                                                                ! being sent. doesn't
                                                                ! necessarily correspond to
                                                                ! the local domains since they
                                                                ! might not all be sent to the
                                                                ! current processor.

        type(mpi_request_vector_t)                  :: mpi_requests

    contains

        procedure   :: init
        procedure   :: init_wait

    end type RASILU0_send_comm_t
    !*******************************************************************************************

contains

    !>  Initialize the data to be sent to proc.
    !!
    !!  - Determine local domains that communicate with the specified processor.
    !!  - For each domain that neighbors proc, communicate information about each overlap element
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   7/22/2016
    !!
    !!
    !!
    !-------------------------------------------------------------------------------------------
    subroutine init(self,mesh,A,proc)
        class(RASILU0_send_comm_t), intent(inout)   :: self
        type(mesh_t),               intent(in)      :: mesh
        type(chidg_matrix_t),       intent(in)      :: A
        integer(ik),                intent(in)      :: proc

        type(ivector_t)             :: dom_send
        integer(ik)                 :: idom, idom_send, ierr, iblk, ielem, iface, &
                                       nelem_send, ielem_send, ielem_n, iface_n, iblk_send, nblks, idiag, imat, imat_n, &
                                       idomain_g_n, ielement_g_n, ielement_l_n, itime
        integer(ik),    allocatable :: send_procs_dom(:)
        logical                     :: comm_domain, overlap_elem
        type(MPI_REQUEST)           :: request

        ! WARNING! Assuming single time-level. Not valid for Harmonic Balance
        itime = 1

        !
        ! Set send processor
        !
        self%proc = proc

        !
        ! Accumulate the domains that send to processor 'proc'
        !
        do idom = 1,mesh%ndomains()

            send_procs_dom = mesh%domain(idom)%get_send_procs_local()
            ! Check if this domain is communicating with 'proc'
            comm_domain = any(send_procs_dom == proc)
            if (comm_domain) call dom_send%push_back(idom)

        end do !idom

        !
        ! Allocate storage for element indices being sent from each dom in dom_send
        !
        allocate(self%dom(dom_send%size()), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! For each domain sending info to 'proc', send data from chidg_matrix.
        !
        do idom_send = 1,dom_send%size()

            idom = dom_send%at(idom_send)
            self%dom(idom_send)%idomain_g = mesh%domain(idom)%idomain_g
            self%dom(idom_send)%idomain_l = mesh%domain(idom)%idomain_l

            !
            ! Loop through element faces and find neighbors that are off-processor on 'proc'
            ! to determine which elements to send as overlap data.
            !
            do ielem = 1,mesh%domain(idom)%nelem
                do iface = 1,NFACES

                    overlap_elem = (mesh%domain(idom)%faces(ielem,iface)%ineighbor_proc == proc)

                    if (overlap_elem) then
                        call self%dom(idom_send)%elem_send%push_back_unique(ielem)
                        exit
                    end if

                end do !iface
            end do !ielem

            nelem_send = self%dom(idom_send)%elem_send%size()
            allocate(self%dom(idom_send)%blk_send(nelem_send), stat=ierr)
            if (ierr /= 0) call AllocationError

            !
            ! Communicate the number of elements being sent to 'proc' for idomain_g
            !
            call MPI_ISend(self%dom(idom_send)%elem_send%size_, 1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
            call self%mpi_requests%push_back(request)

            !
            ! For each element in the overlap, determine which linearization blocks to send
            !
            do ielem_send = 1,self%dom(idom_send)%elem_send%size()
                ielem = self%dom(idom_send)%elem_send%at(ielem_send)

                !
                ! Communicate the indices of the element being sent
                !
                call MPI_ISend(mesh%domain(idom)%elems(ielem)%idomain_g,  1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                call self%mpi_requests%push_back(request)
                call MPI_ISend(mesh%domain(idom)%elems(ielem)%ielement_g, 1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                call self%mpi_requests%push_back(request)

                !
                ! Search for blocks to send that couple with the off-processor domain
                !
                do imat = 1,A%dom(idom)%lblks(ielem,1)%size()
                     if ( A%dom(idom)%lblks(ielem,1)%parent_proc(imat) == proc ) then
                         call self%dom(idom_send)%blk_send(ielem_send)%push_back(imat)
                     end if
                end do

                !
                ! Search neighbors to see if any of them are also overlapping blocks,
                ! because we would need to send their linearization as well.
                !
                do iface = 1,NFACES

                    ! Get neighbor for iface
                    if ( (mesh%domain(idom)%faces(ielem,iface)%ftype          == INTERIOR) .and. &
                         (mesh%domain(idom)%faces(ielem,iface)%ineighbor_proc == IRANK   ) ) then

                        idomain_g_n  = mesh%domain(idom)%faces(ielem,iface)%ineighbor_domain_g
                        ielement_g_n = mesh%domain(idom)%faces(ielem,iface)%ineighbor_element_g
                        ielement_l_n = mesh%domain(idom)%faces(ielem,iface)%ineighbor_element_l

                        !
                        ! Find linearization of ielem wrt neighbor, ielem_n
                        !
                        imat_n = A%dom(idom)%lblks(ielem,1)%loc(idomain_g_n,ielement_g_n,itime)

                        do imat = 1,A%dom(idom)%lblks(ielement_l_n,1)%size()
                             if ( (A%dom(idom)%lblks(ielement_l_n,1)%parent_proc(imat) == proc ) .and. &
                                  (A%dom(idom)%lblks(ielement_l_n,1)%dparent_g(imat)   == self%dom(idom_send)%idomain_g) ) then
                                 call self%dom(idom_send)%blk_send(ielem_send)%push_back(imat_n)
                                 exit
                             end if
                        end do

                    end if

                end do

                !
                ! Add the block diagonal to the list to send
                !
                idiag = A%dom(idom)%lblks(ielem,1)%get_diagonal()
                call self%dom(idom_send)%blk_send(ielem_send)%push_back(idiag)

                ! Communicate the number of blocks being sent to 'proc' for element
                call MPI_ISend(self%dom(idom_send)%blk_send(ielem_send)%size_, 1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                call self%mpi_requests%push_back(request)

                ! Communicate which blocks are being send to 'proc' for element
                nblks = self%dom(idom_send)%blk_send(ielem_send)%size()
                call MPI_ISend(self%dom(idom_send)%blk_send(ielem_send)%data_(1:nblks), nblks, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                call self%mpi_requests%push_back(request)

                ! For each block send block initialization data
                do iblk_send = 1,self%dom(idom_send)%blk_send(ielem_send)%size()
                    iblk = self%dom(idom_send)%blk_send(ielem_send)%at(iblk_send)

                    call MPI_ISend(A%dom(idom)%lblks(ielem,1)%data_(iblk)%nterms,       1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                    call self%mpi_requests%push_back(request)

                    call MPI_ISend(A%dom(idom)%lblks(ielem,1)%data_(iblk)%nfields,      1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                    call self%mpi_requests%push_back(request)

                    call MPI_ISend(A%dom(idom)%lblks(ielem,1)%data_(iblk)%dparent_g_,   1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                    call self%mpi_requests%push_back(request)

                    call MPI_ISend(A%dom(idom)%lblks(ielem,1)%data_(iblk)%dparent_l_,   1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                    call self%mpi_requests%push_back(request)

                    call MPI_ISend(A%dom(idom)%lblks(ielem,1)%data_(iblk)%eparent_g_,   1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                    call self%mpi_requests%push_back(request)

                    call MPI_ISend(A%dom(idom)%lblks(ielem,1)%data_(iblk)%eparent_l_,   1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                    call self%mpi_requests%push_back(request)

                    call MPI_ISend(A%dom(idom)%lblks(ielem,1)%data_(iblk)%parent_proc_, 1, MPI_INTEGER4, proc, self%dom(idom_send)%idomain_g, ChiDG_COMM, request, ierr)
                    call self%mpi_requests%push_back(request)

                end do !iblk_send

            end do !ielem send

        end do !idom send

    end subroutine init
    !******************************************************************************************

    !>  Call MPI_Waitall for all ISend nonblocking sends that were initiated during the
    !!  initialization procedure.
    !!
    !!  This routine should be called after both 'send%init' and 'recv%init' have been executed
    !!  in the main RASILU0 preconditioner initialization.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   01/08/2016
    !!
    !!
    !------------------------------------------------------------------------------------------
    subroutine init_wait(self)
        class(RASILU0_send_comm_t),     intent(inout)   :: self

        integer(ik) :: nwait, ierr

        nwait = self%mpi_requests%size()
        if (nwait > 0) then

            ! Wall on all requests and free buffers
            call MPI_Waitall(nwait, self%mpi_requests%data(1:nwait), MPI_STATUSES_IGNORE, ierr)

            ! Clear storage vector
            call self%mpi_requests%clear()

        end if

    end subroutine init_wait
    !******************************************************************************************

end module type_RASILU0_send_comm


ALLSEL
!------------------- Apply loads to the rail --------------------------
!----------------------------------------------------------------------
!Requires set loadtables. Originally generated in Parameters/Loads
! aangrijpingspunt is midden van de rail, over een lengte van force_length symmetrisch vanuit het centrum in rail/lengte-richting.

*IF, A_54E1, GT, 0.0001, THEN
	force_length = A_54E1
*ELSE
	force_length = 0.02 !m Default
*ENDIF

!Left area:
*GET, DoesCompExists, COMP, LoadNodes_LEFT, TYPE
*IF, DoesCompExists, GT, 0, THEN
	CMSEL, S, LoadNodes_LEFT
*ELSE
	CSYS, CS_Rail_L !Use local coordinate system
	CMSEL, S, Rail_V
	NSLV, S, 1 !select nodes corresponding to selected volume.
	NSEL, R, LOC, Y, Force_apllication_height
	NSEL, R, LOC, Z, -force_length/2, force_length/2
	NSEL, R, LOC, X, LoadLocation_X-force_length/2, LoadLocation_X+force_length/2 !LoadLocation_X makes it possible to change the location of loading.
	CM, LoadNodes_LEFT, NODE
*ENDIF
*GET, AantalNodes_LEFT, NODE, 0, COUNT,

!Right area:
*GET, DoesCompExists, COMP, LoadNodes_RIGHT, TYPE
*IF, DoesCompExists, GT, 0, THEN
	CMSEL, S, LoadNodes_RIGHT !This function is not used as it is not possible (jet) to assign nodes before generation of the geometry or to acces this geometry after generation.
*ELSE
	CSYS, CS_Rail_R !Use local coordinate system
	CMSEL, S, Rail_V
	NSLV, S, 1 !select nodes corresponding to selected volume.
	NSEL, R, LOC, Y, Force_apllication_height
	NSEL, R, LOC, Z, -force_length/2, force_length/2
	NSEL, R, LOC, X, LoadLocation_X-force_length/2, LoadLocation_X+force_length/2
	CM, LoadNodes_RIGHT, NODE
*ENDIF
*GET, AantalNodes_RIGHT, NODE, 0, COUNT,

CSYS, 0 !Return to standard coordinate system

!----------------------------------------------------------------------
!------- loading: -----------------------------------------------------
!----------------------------------------------------------------------
*IF, AantalNodes_LEFT, GT, 0, THEN
*TOPER, LoadTable_z_L_scaled, LoadTable_z_L, ADD, LoadTable_z_L , 1/AantalNodes_LEFT, 0 , !Scale force to a force per node.
*TOPER, LoadTable_y_L_scaled, LoadTable_y_L, ADD, LoadTable_y_L, 1/AantalNodes_LEFT, 0 ,  !Scale force to a force per node.
*ENDIF
*IF, AantalNodes_RIGHT, GT, 0, THEN
*TOPER, LoadTable_z_R_scaled, LoadTable_z_R, ADD, LoadTable_z_R , 1/AantalNodes_RIGHT, 0 , !Scale force to a force per node.
*TOPER, LoadTable_y_R_scaled, LoadTable_y_R, ADD, LoadTable_y_R, 1/AantalNodes_RIGHT, 0 ,  !Scale force to a force per node.
*ENDIF

!Create substeps

*DO, n, 1, LoadSteps
	ALLSEL
	TIME, TimeArray(n)
	ACEL,,9.81 !In the absence of any other loads or supports, the acceleration of the structure in each of the global Cartesian (X, Y, and Z) axes would be equal in magnitude but opposite in sign to that applied in the ACEL command. Thus, to simulate gravity (by using inertial effects), accelerate the reference frame with an ACEL command in the direction opposite to gravity.
	!NSUBST, NumberOfSubsteps      	! Use appropriate time step
	AUTOTS, ON !Substep / timestep to auto (is default, but apply explicitly)

	KBC,0             				! Ramped loads (if appropriate)

	*IF, AantalNodes_LEFT, GT, 0, THEN
		CMSEL, S, LoadNodes_LEFT
		!----------------
		*IF, LoadType(1), EQ, 'Force', THEN
			F, ALL, FZ, %LoadTable_z_L_scaled%, , ,
			F, ALL, FY, %LoadTable_y_L_scaled%, , ,
		*ELSE !LoadType = displacement
			LoadType(1) = 'Displacement'
			D, ALL, UZ, %LoadTable_z_L%, , ,
			D, ALL, UY, %LoadTable_y_L%, , ,
		*ENDIF
	*ENDIF

	*IF, AantalNodes_RIGHT, GT, 0, THEN
		CMSEL, S, LoadNodes_RIGHT
		!----------------
		*IF, LoadType(1), EQ, 'Force', THEN
			F, ALL, FZ, %LoadTable_z_R_scaled%, , ,
			F, ALL, FY, %LoadTable_y_R_scaled%, , ,
		*ELSE !LoadType = displacement
			LoadType(1) = 'Displacement'
			D, ALL, UZ, %LoadTable_z_R%, , ,
			D, ALL, UY, %LoadTable_y_R%, , ,
		*ENDIF
	*ENDIF
	ALLSEL

	LSWRITE           ! Write load data to load step file (Jobname.S0x)
*ENDDO

*DEL, AantalNodes_LEFT
*DEL, AantalNodes_RIGHT

ALLSEL


 	SUBROUTINE SF_CSDP  ( filnam, prmfil, iflsrc, maxrpt, stmflg,
     +			      isffln, nparm,  parms,  pkflg,  iret )
C************************************************************************
C* SF_CSDP								*
C*									*
C* This subroutine creates a new ship surface data file.  The		*
C* file will store times and stations together as columns in row	*
C* 1.  This type of file may be used to store data if the station	*
C* locations vary, such as for ship reports.				*
C*									*
C* The parameter packing file named in PRMFIL will determine the 	*
C* parameters to be contained in the data set and the packing, if any,	*
C* to be used.  PKFLG is set on output if the data are to be packed.	*
C* All data packing and unpacking will be done internally.  This	*
C* subroutine is identical to SF_CSDF except that the packing 		*
C* information is read from a packing file in this subroutine.		*
C* The data packing file is described in the introduction to this	*
C* chapter.								*
C*									*
C* If the station time flag is set, a single word is allocated with 	*
C* each data report to store the report time (HHMM).  This time 	*
C* should be sent with the report.					*
C*									*
C* The subroutine SF_WSDD will write data to this file.  The		*
C* data can be read using SF_RDAT, so all GEMPAK programs will be	*
C* able to read this file.						*
C*									*
C* The data source values are parameters in GEMPRM.PRM .		*
C* These are not currently used by any GEMPAK program.  Current		*
C* definitions include:							*
C*      MFUNKN        unknown						*
C*      MFAIRW        airways surface observation			*
C*      MFMETR        Metar report					*
C*      MFSHIP        ship report					*
C*      MFBUOY        buoy report					*
C*      MFSYNP        synoptic report					*
C*									*
C* SF_CSDP  ( FILNAM, PRMFIL, IFLSRC, MAXRPT, STMFLG, ISFFLN, NPARM,	*
C*            PARMS,  PKFLG,  IRET )					*
C*									*
C* Input parameters:							*
C*	FILNAM		CHAR*		Surface file name		*
C*	PRMFIL		CHAR*		Parameter packing file name 	*
C*	IFLSRC		INTEGER		Data source 			*
C*	MAXRPT		INTEGER	 	Maximum number of reports	*
C*	STMFLG		LOGICAL		Station time flag		*
C*									*
C* Output parameters:							*
C*	ISFFLN		INTEGER		Surface file number		*
C*	NPARM		INTEGER		Number of parameters 		*
C*	PARMS (NPARM)	CHAR*4		Parameter names 		*
C*	PKFLG		LOGICAL		Parameter packing flag		*
C*	IRET		INTEGER		Return code			*
C*				    	  0 = normal return		*
C*				   	 -1 = file not created		*
C**									*
C* Log:									*
C* I. Graffman/RDS	 4/87	SF_CRFP					*
C* M. desJardins/GSFC	 2/88	Single dimension version		*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* S. Jacobs/NCEP	 7/96	Updated documentation			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GMBDTA.CMN'
	INCLUDE 	'sfcmn.cmn'
C*
	CHARACTER*(*) 	filnam, prmfil, parms (*)
	INTEGER		iscale (MMPARM), iofset (MMPARM), ibits (MMPARM)
	LOGICAL 	pkflg, stmflg
C------------------------------------------------------------------------
	iret = 0
C
C*	Get parameter information
C
	CALL DP_FILE  ( prmfil, nparm, parms, iscale, iofset, ibits,
     +			pkflg,  iret )
C
C*	Write error messages.
C
	IF  ( iret .ne. 0 )  THEN
	    CALL ER_WMSG  ( 'DP', iret, prmfil, ier )
	    iret = -1
	    CALL ER_WMSG  ( 'SF', iret, filnam, ier )
	    RETURN
	END IF
C
C*	Create the file.
C
	CALL SF_CSDF  ( filnam, iflsrc, nparm, parms,  maxrpt, pkflg,
     +			iscale, iofset, ibits, stmflg, isffln, iret )
C*
	RETURN
	END


C    @(#)presln.f	20.9 8/20/98
      subroutine presln

      include 'ipfinc/parametr.inc'

      include 'ipfinc/alpha.inc'
      include 'ipfinc/beta.inc'
      include 'ipfinc/blank.inc'
      include 'ipfinc/branch.inc'
      include 'ipfinc/bus.inc'
      include 'ipfinc/cbus.inc'
      include 'ipfinc/com008.inc'
      include 'ipfinc/ecvar.inc'
      include 'ipfinc/intbus.inc'
      include 'ipfinc/komps.inc'
      include 'ipfinc/lfiles.inc'
      include 'ipfinc/optim1.inc'
      include 'ipfinc/pctvr2.inc'
      include 'ipfinc/phase.inc'
      include 'ipfinc/prt.inc'
      include 'ipfinc/qksrt.inc'
      include 'ipfinc/slnopt.inc'
      include 'ipfinc/snput.inc'
      include 'ipfinc/strce.inc'
      include 'ipfinc/tbx.inc'
      include 'ipfinc/tran.inc'
      include 'ipfinc/xdata.inc'
C
      common /is_batch / is_batch

      external kmpqpn, swpqpn, kmpecn, swpecn,
     &         komprs, swaps,  kmpbt,  swpbt,  kmplt,  swplt

      integer find_bus, find_zon, error

      character jtyp*1, cbtype*1, type*8
C
      lprtsw = 1
      fichsw = 0
      if (kspare(16).ge.0) fichsw = 1
      nbttot = 0
      ntttot = 0
      islnsw=0
      ntopt=0
      ntot11=0
      nsen=0
      ngen=0
      ncvrt=0
      nqpen=0
      nvpen=0
      qpen=0
      nntyp9=0
      nltc=0
      karslk = 0
      npctvr = 0
      nldc = 0
      idckt = 0
      inptls=1
C
      do 160 i=1,ntot
         buspen(i)=0.0
  160 continue

  170 if (buf(1:1) .eq. '(') then
        islnsw = 0
        goto 1330

      else
        call sinput
      endif

      if (islnsw.eq.0) go to 1330

C     ISLNSW HAS THE FOLLOWING ATTRIBUTES

C       0 -- NORMAL
C       1 -- OPTIMIZE ZONES
C       2 -- OPTIMIZE REACTIVE
C       3 -- OPTIMIZE DISPATCH
C       4 -- INCLUDE BUSES
C       5 -- EXCLUDE BUSES
C       6 -- /SENSITIVITIES
C       7 -- /TRACE BUSES
C       8 -- /TRACE LTC'S
C       9 -- /GEN_DPOP
C
C              1   2    3   4   5    6     7     8     9
      go to (180,700,1050,310,310,1200,10300,10500,10700) islnsw

C     OPTIMAL CHANGES BY ZONES

  180 if (ncvrt.ne.0) go to 1900
      iopton(20)=1
      call qiksrt (1,idat,komprs,swaps)
      do 200 i=1,ntot
      j = find_zon(zone(i))
      if (j.le.0) go to 190
      j=1
      go to 200

  190 j=0
  200 nbsort(i)=j
      write (outbuf,210)
  210 format ('0 OPTIMAL CHANGES PERFORMED TEMPORARILY FOR BUSSES ',
     1        'WITHIN THE FOLLOWING ZONES' )
      call prtout(1)
      call space (1)
      iend = 0
  230 continue
      ist = iend + 1
      iend = ist + 9
      if( iend .gt. idat ) iend = idat
      write (outbuf,240) (zondat(i),i=ist,iend)
  240 format( 10(4x,'(',a2,')  ' ))
      call prtout(1)
      if( iend.lt.idat ) go to 230
C
C     CHECK FOR INCLUDED OR EXCLUDED BUSES
C
      call sinput
      if (islnsw.eq.5) go to 250
      if (islnsw.ne.4) go to 300
      isw=1
      go to 260

  250 isw=0
  260 do 290 i=1,idat
         kbus = find_bus(namdat(i),bsedat(i))
         if (kbus .gt. 0) go to 280
         type = 'INCLUDED'
         if(islnsw.ne.4) type = 'EXCLUDED'
         write (errbuf(1),270) type,namdat(i),bsedat(i)
  270    format ('0 ',a8,' BUS ',a8,f7.1,
     1           ' IN OPTIMAL CHANGE SET IS NOT IN THE SYSTEM.')
      call prterx ('W',1)
      go to 290

  280 nbsort(kbus)=isw
  290 continue
      call sinput
  300 if (islnsw.eq.0) go to 330
      go to (1900,330,330,260,260,330), islnsw
  310 write (errbuf(1),320) buf(1:50)
  320 format ('0 ILLEGAL SOLUTION CONTROL CARD SEQUENCE :(', a, ')')
      if (is_batch .eq. 0) then
         call prterx ('E',1)
      else
         call prterx ('F',1)
      endif
      go to 170

  330 do 340 k=1,ntot
         if (nbsort(k).eq.0) go to 340
         kt=inp2opt(k)
         buspen(kt)=vpen
  340 continue
      do 350 k=1,ntot
  350 nbsort(k)=0
      if (ntotb.eq.0) go to 380
C
C     CONVERT TYPES "BQ", "BG", AND "BX" BUSSES IN OPTIMAL ZONES INTO
C     TEMPORARY TYPE "BO" BUSSES
C
      do 370 i=1,ntotb
         ltyp=tbx(1,i)
         if (ltyp.ge.10) go to 370
         kt=tbx(2,i)
         nbsort(kt)=i
  370 continue
  380 continue
      do 650 nb=1,ntot
      k=inp2opt(nb)
      if (buspen(k).eq.0.0) go to 650
      ntyp = ntypu(k)
      kmod=0
      jtbx=0
      jxdta=0
      ntypo=ntyp
      v=dsqrt(e(k)**2+f(k)**2)
      emin=vlimn(k)
      emax=vlimx(k)
      oldmin = busdta(11,nb)
      oldmax = busdta(12,nb)
      go to (400,390,390,390,400,400,390,400,400,390,400,400,390,395,
     1       395,395) ntyp

  390 busdta(11,nb)=0.0
      busdta(12,nb)=0.0
      go to 400

  395 busdta(11,nb)=0.0
  400 call vltlim(nb,vmin,vmax,vstrt)
      vmin=amin1(emin,vmin)
      vmax=amax1(emax,vmax)
C
C     "IOPTON(36)" IS BASE CASE VOLTAGE RELAXATION OPTION
C
      if (iopton(36).eq.0) go to 410
      vmin = amin1 (v,vmin)
      vmax = amax1 (v,vmax)
  410 vlimn(k) = vmin
      vlimx(k) = vmax
      if (vmin.eq.emin.and.vmax.eq.emax) go to 430
      kmod = 1
      call typno (jtyp,ntyp)
      write (outbuf,420) intbus(nb),intbas(nb),jtyp,v,emin,emax,
     1  vmin,vmax
  420 format (' VOLTAGE LIMITS RELAXED ON BUS ',a8,f7.1,' TYPE ',a1
     1  ,' VOLTAGE ',f6.4,' OLD LIMITS - ',2f7.4,' NEW LIMITS - ',2f7.4)
      call prtout(1)
  430 go to (510,510,600,510,650,440,440,440,640,510,440,650,440,
     1       510,510,440) ntyp
  440 jtbx=nbsort(k)
      ltyp=tbx(1,jtbx)
      ityp=tbx(7,jtbx)
      go to (450,470,460,650,500,450), ltyp
C
  450 if (ityp.ne.1) qnetu(k)=tbx(5,jtbx)
      tbx(1,jtbx)=11
      tbx(7,jtbx)=1
      go to 490
C
  460 qmin=tbx(4,jtbx)
      qmax=tbx(3,jtbx)
      go to 480
C
  470 tbx(1,jtbx)=4
      ntyp=9
      go to 490
C
  480 continue
      tbx(3,jtbx)=qmax-dmin1(0.0d0,tbx(6,jtbx)*v**2)
      tbx(4,jtbx)=qmin-dmax1(0.0d0,tbx(6,jtbx)*v**2)
      tbx(5,jtbx)=v
      tbx(1,jtbx)=4
      tbx(7,jtbx)=1
      ntyp=9
  490 kmod=1
      go to 610
C
  500 jxdta=tbx(5,jtbx)
      totrek=xdata(3,jxdta)
      totcap=xdata(4,jxdta)
      userek=xdata(5,jxdta)
      usecap=xdata(6,jxdta)
      bkku(k) = bkku(k) +(totrek+totcap-usecap-userek)/bmva
      xdata(5,jxdta)=totrek
      xdata(6,jxdta)=totcap
      go to 460
C
  510 continue
      qmax=busdta(9,nb)
      qmin=busdta(10,nb)
      bkkadj=busdta(6,nb)
      ncb=kbsdta(15,nb)
      do while (ncb .gt. 0)
         call getchr(1,cbtype,kbctbl(8,ncb))
         if (cbtype.ne. 'A') bkkadj = bkkadj + bctbl(5,ncb) / bmva
         ncb = bctbl_nxt(ncb)
      enddo

      bkkadj=bkkadj/bmva
      if (ntyp .eq. 2 .or. ntyp .eq. 15) go to 560
      if (abs(bkkadj).gt.0.50) go to 550
      if (qmax-qmin.lt.25.0) go to 600
  550 continue
C
C     LOAD BUSSES WITH ADJUSTABLE REACTIVE AND TYPE 'E' BUSSES ARE
C     CHANGED ULTIMATELY TO SUB-TYPE 'Q'.
C
  560 call typno (jtyp,ntyp)
      write (outbuf,570) intbus(nb),intbas(nb),jtyp,bkkadj,qmax,qmin
      call prtout(1)
  570 format(' OPTIMAL CHANGES MODIFIED BUS ',a8,f7.1,' TYPE ',a1,
     1' adjustable shunt ',f7.1,' mvar -- generator reactive limits '
     2 ,2f8.3)
      ntotb = ntotb + 1
      if (ntotb.le.MAXTBX) go to 590
      write (errbuf(1),580) MAXTBX
  580 format('0 OPTIMAL CHANGES HAVE CREATED MORE THAN ',i4,' "TBX" ',
     1 'entities. further optimal changes curtailed.')
      call prterx ('W',1)
      ntotb=MAXTBX
      go to 610
C
  590 ntyp=9
      if (ntyp .eq. 2 .and. iopton(37) .ne. 0) then
         ntypo=2
         qmax=1.0e8
         qmin=1.0e8
      else if (ntyp .eq. 15 .and. iopton(37) .ne. 0) then
         ntypo=15
         qmax=1.0e8
         qmin=1.0e8
      else
         ntypo=7
      endif
C
      kmod=1
      tbx(1,ntotb)=4
      tbx(2,ntotb)=k
      tbx(3,ntotb)=qmax/bmva-qloadu(k)-amin1(0.0,bkkadj*v**2)
      tbx(4,ntotb)=qmin/bmva-qloadu(k)-amax1(0.0,bkkadj*v**2)
      tbx(5,ntotb)=v
      tbx(6,ntotb)=bkkadj
      tbx(7,ntotb)=1
      tbx(8,ntotb)=0
      go to 610
C
  600 if (kmod.eq.0) go to 650
  610 ncvrt=ncvrt+1
      if (ncvrt.le.MXOPCH) go to 630
      write (errbuf(1),620) MXOPCH
  620 format('0 MORE THAN ',i4,' OPTIMAL BUS CHANGES.  FUTHER CHANGES ',
     1' curtailed.')
      call prterx ('W',1)
      ncvrt=MXOPCH
      go to 660
C
  630 knvert(1,ncvrt)=k
      knvert(2,ncvrt)=ntypo
      knvert(3,ncvrt)=jtbx
      knvert(4,ncvrt)=jxdta
      ntypu(k) = ntyp
  640 if (ntyp.eq.3.or.ntyp.eq.9) nntyp9=nntyp9+1
  650 continue
  660 continue
      if (ntota.eq.0) go to 690
C
      do 680 i=1,ntota
      ltyp=ltran(10,i)
      knvtx(i)=ltyp
      if (ltyp.ne.1) go to 680
      k=ltran(1,i)
      m=ltran(2,i)
      if(buspen(k).eq.0.0 .and. buspen(m) .eq. 0.0) go to 680
      ltran(10,i)=4
      nltc=nltc+1
  680 continue
  690 continue
      go to 170
C
C     PROCESS REACTIVE PENALTY BUSSES
C
  700 if (nqpen.ne.0) go to 1900
      iopton(20)=1
      ksw=1
      do 970 i=1,idat
      nb = find_bus(namdat(i),bsedat(i))
      if (nb .gt. 0) go to 720
      write (errbuf(1),710) namdat(i),bsedat(i)
  710 format ('0 REACTIVE PENALTY BUS ',a8,f7.1,' IS NOT IN SYSTEM.')
      call prterx ('W',1)
      go to 970
C
  720 kt=inp2opt(nb)
      if (buspen(kt).eq.0.0) go to 750
      if (ntypu(kt).ne.5.and.ntypu(kt).ne.12) go to 770
      write (errbuf(1),740) intbus(kt),intbas(kt)
  740 format ('0 DATA ERROR --  DC BUS ',a8,f7.1,' CANNOT HAVE REACTIVE
     1penalties.  bus ignored. ')
      call prterx ('W',1)
      go to 970
C
  750 write (errbuf(1),760) intbus(kt),intbas(kt)
  760 format ('0 DATA ERROR --  BUS ',a8,f7.1,' WITH REACTIVE PENALTIES
     1must reside in optimized system.  bus ignored. ')
      call prterx ('W',1)
      go to 970
C
  770 if (ncvrt.eq.0) go to 790
      do 780 l=1,ncvrt
      if (knvert(1,l).eq.kt) go to 810
  780 continue
  790 ncvrt=ncvrt+1
      if (ncvrt.le.MXOPCH) go to 800
      write (errbuf(1),620) MXOPCH
      call prterx ('W',1)
      ncvrt=MXOPCH
      ksw=2
      go to 970
C
  800 knvert(1,ncvrt)=kt
      l=ncvrt
  810 continue
      if (ksw.eq.2) go to 970
      nqpen=nqpen+1
      if (nqpen.le.MXQPEN) go to 830
      write (errbuf(1),820)
  820 format ('0 MORE THAN ',i4,' REACTIVE PENALTY BUSES.  REMAINDER ',
     1'ignored. ')
      call prterx ('W',1)
      nqpen=MXQPEN
      ksw=2
      go to 980
C
  830 kqpent(1,nqpen)=nb
      qcon = -busdta(4,nb)
      bkkadj = busdta(6,nb)
      qmax=busdta(9,nb)
      qmin=busdta(10,nb)
      ncb=kbsdta(15,nb)
      do while (ncb .gt. 0)
         call getchr(1,cbtype,kbctbl(8,ncb))
         if (cbtype .ne. 'A') then
            bkkadj=bkkadj + bctbl(5,ncb)
            qcon=qcon-bctbl(3,ncb)
         endif
         ncb = bctbl_nxt(ncb)
      enddo

      ntypu(kt) = 9
      kqpent(2,nqpen)=ntypu(kt)
      jtbx=knvert(4,l)
      jxdta=knvert(3,l)
      knvert(2,l)=2
      knvert(3,l)=0
      knvert(4,l)=0
      if (jtbx.eq.0) go to 950
      ltyp=tbx(1,jtbx)
      ityp=tbx(7,jtbx)
      if (ltyp.gt.9) go to 950
      go to (940,870,880,870,890,940) ltyp
  870 go to (940,950,910,920) ityp
  880 go to (940,930,930,940,940), ityp
  890 go to (940,930,930,900), ityp
  900  totrek=xdata(3,jxdta)
       totcap=xdata(4,jxdta)
       userek=xdata(5,jxdta)
       usecap=xdata(6,jxdta)
       bkku(kt) = bkku(kt) + (totrek+totcap - usecap - userek)/bmva
       xdata(5,jxdta)=totrek
       xdata(6,jxdta)=totcap
      go to 930
C
  910 bkku(kt) = bkku(kt) + dmax1(0.0d0,tbx(6,jtbx))
      go to 930
C
  920 bkku(kt) = bkku(kt) + dmin1(0.0d0,tbx(6,jtbx))
  930 c=tbx(5,jtbx)/dsqrt(e(kt)**2+f(kt)**2)
      e(kt)=e(kt)*c
      f(kt)=f(kt)*c
  940 tbx(1,jtbx)=ltyp+10
      tbx(7,jtbx)=1
  950 emag=dsqrt(e(kt)**2+f(kt)**2)
      dv=dim(emag,vlimx(kt)) - dim(emag,vlimn(kt))
      if (dv.eq.0.0) go to 960
      c = (emag - dv)/emag
      e(kt)=e(kt)*c
      f(kt)=f(kt)*c
      emag = emag - dv
  960 qpent(3,nqpen) = (qmin + qcon - amax1(0.0,bkkadj)*emag**2)/bmva
      qpent(4,nqpen) = (qmax + qcon - amin1(0.0,bkkadj)*emag**2)/bmva
  970 continue
  980 if (nqpen.gt.0) go to 1000
      write (errbuf(1),990)
  990 format('0 NO BUS DATA FOLLOWS "REACTIVE PENALTIES" SOLUTIONS ',
     1 'text.')
      call prterx ('W',1)
      qpen=0.0
      call sinput
      go to 170
 1000 ndup=0
      call qiksrt(1,nqpen,kmpqpn,swpqpn)
      if (ndup.eq.0) go to 1030
C
C     ELIMINATE DUPLICATE DATA ITEMS
C
      j=1
      k=2
 1010 if(kmpqpn(j,k).lt.0)then
         j=j+1
         if(j.lt.k) call swpqpn(j,k)
         k=k+1
      else
         nb=kqpent(1,j)
         kt = inp2opt(nb)
         write (errbuf(1),1020) intbus(kt),intbas(kt)
 1020    format('0 DUPLICATE "REACTIVE PENALTY BUS ": ',a8,f6.1,'.',
     1   ' second item deleted.')
         call prterx ('W',1)
         k=k+1
      endif
C
      if(k.le.nqpen) go to 1010
      nqpen=j
 1030 do 1040 i=1,nqpen
      nb=kqpent(1,i)
 1040 kqpent(1,i)=inp2opt(nb)
      call sinput
      go to 170
C
C     PROCESS ECONOMIC DISPATCH BUSSES
C
 1050 if (ngen.ne.0) go to 1900
      iopton(20)=1
      ksw=1
      do 1100 i=1,idat
      nb = find_bus(namdat(i),bsedat(i))
      if (nb .gt. 0) go to 1070
      write (errbuf(1),1060) namdat(i),bsedat(i)
 1060 format ('0 ECONOMIC DISPATCH BUS ',a8,f7.1,' IS NOT IN SYSTEM. ',
     1'dispatch aborted. ')
      call prterx ('W',1)
      ksw=2
      go to 1100
 1070 if (ksw.eq.2) go to 1100
      ngen=ngen+1
      if (ngen.le.MXDISP) go to 1090
      write (errbuf(1),1080) MXDISP
 1080 format ('0 MORE THAN ',i4,' DISPATCHABLE BUSSES. OPTIMAL ',
     1'dispatch aborted. ')
      call prterx ('W',1)
      ksw=2
      ngen=MXDISP
      go to 1100
 1090 kecon(1,ngen)=nb
      econ(2,ngen)=0
      econ(3,ngen)=data(1,i)
      econ(4,ngen)=data(2,i)
      econ(5,ngen)=0.0
      econ(6,ngen)=0.0
      econ(7,ngen)=0.0
      econ(8,ngen)=data(3,i)
      econ(9,ngen)=data(4,i)
      econ(10,ngen)=data(5,i)
 1100 continue
      if (ksw.eq.2) go to 170
      if (ngen.gt.0) go to 1130
      write (errbuf(1),1120)
 1120 format('0 NO BUS DATA FOLLOWS "ECONOMIC DISPATCH" SOLUTION TEXT.')
      call prterx ('W',1)
      go to 170
 1130 ndup=0
      call qiksrt(1,ngen,kmpecn,swpecn)
      if (ndup.eq.0) go to 1160
C
C     ELIMINATE DUPLICATE DATA ITEMS
C
      j=1
      k=2
 1140 if(kmpecn(j,k).lt.0)then
         j=j+1
         if(j.lt.k)call swpecn(j,k)
         k=k+1
      else
         nb=kecon(1,j)
         kt = inp2opt(nb)
         write (errbuf(1),1150) intbus(kt),intbas(kt)
 1150    format('0 DUPLICATE "ECONOMIC DISPATCH" BUS: ',a8,f6.1,'. ',
     1'second item deleted.')
         call prterx ('W',1)
         k=k+1
      endif
      if (k.le.ngen) go to 1140
      ngen=j
 1160 do 1170 i=1,ngen
      nb=kecon(1,i)
 1170 kecon(1,i)=inp2opt(i)
      do 1190 ig=1,ngen
      kt=kecon(1,ig)
      pgen=pnetu(kt) +ploadu(kt)
      dp=dim(pgen,econ(4,ig)/bmva)-dim(econ(3,ig)/bmva,pgen)
      if (dp.eq.0.0) go to 1190
      write (outbuf,1180) intbus(kt),intbas(kt),pgen,dp
 1180 format ('0 ECONOMIC DISPATCHABLE BUS ',a8,f7.1,' WITH GENERATOR',
     1 e11.4,' violates limits by ',e11.4,' pu mw.')
      call prterx ('W',1)
      econ(3,ig)=econ(3,ig)+amin1(0.0,dp)*bmva
      econ(4,ig)=econ(4,ig)+amax1(0.0,dp)*bmva
 1190 continue
      go to 170
C
C     Store "INJECTION SENSTIIVITIES" until OPSLN3.
C
 1200 continue
      go to 1330
C
C     PROCESS TRACE BUSES
C
10300   nbttot = 0
        do 10320 i=1,idat
           kt = find_bus( namdat(i) , bsedat(i) )
           if ( kt .le. 0 ) then
              write (errbuf(1),10310) namdat(i),bsedat(i)
10310         format('0 "TRACE_BUS" ',a8,f7.1,' IS NOT IN SYSTEM.'
     1          ,'  bus ignored.')
              call prterx ('W',1)
           else
              nbttot = nbttot + 1
              ibus(1,nbttot) = kt
           endif
10320   continue
C
C  ERROR IF NO VALID "TRACE_BUS" DATA REMAINS
C
        if (nbttot.gt.0) go to 10410
        write (errbuf(1),10400)
10400   format('0 NO VALID BUS DATA FOLLOWS "TRACE_BUS" SOLUTION TEXT.')
        call prterx ('W',1)
        go to 170
10410   key=0
        call qiksrt(1,nbttot,kmpbt,swpbt)
        if (key.eq.0) go to 10440
C
C     ELIMINATE DUPLICATE BUSES
C
        j=1
        k=2
10420   if(kmpbt(j,k).lt.0) then
                j=j+1
                if(j.lt.k)call swpbt(j,k)
                k=k+1
           else
                nb=ibus(1,j)
                kt=inp2opt(nb)
                write (errbuf(1),10430) intbus(kt),intbas(kt)
10430           format('0 DUPLICATE "TRACE_BUS" ',a8,f7.1,'. ',
     1          'second item ignored.')
                call prterx ('I',1)
                k=k+1
           endif
        if(k.le.nbttot) go to 10420
        nbttot=j
C
C  CONVERT TO INTERNAL BUS NUMBERS
C
C  STORE INDEX TO TBX ARRAY FOR BUS TYPES V,Q,G,O,X,F,L
C                         -1 FOR BUS TYPES 'blank',C,D,T,M,J
C                         -2 FOR BUS TYPES E,S,K
C
10440   do 10460 i=1,nbttot
           nb=ibus(1,i)
           kt=inp2opt(nb)
           ibus(1,i)=kt
           ntyp = kbsdta(1,nb)
           indtbx = tbxtyp(ntyp)
           if (indtbx .gt. 0 )          then
                ibus(3,i) = - indtbx
              else
                j = 1
10450           ktest = tbx(2,j)
                if( ktest .eq. kt ) then
                        ibus(3,i) = j
                   else
                        j = j + 1
                        if( j .le. MAXTBX ) go to 10450
                   endif
              endif
10460   continue
         go to 170
C
C  PROCESS TRACE LTC'S
C
10500   ntttot = 0
        do 10520 i=1,idat,2
        kt = find_bus( namdat(i) , bsedat(i) )
        mt = find_bus( namdat(i+1) , bsedat(i+1) )
        if ( kt .le. 0 .or. mt .le. 0 ) then
           write (errbuf(1),10510) namdat(i),bsedat(i), namdat(i+1),
     &                             bsedat(i+1)
10510      format('0 "TRACE_LTC" ',a8,f7.1,4x,a8,f7.1,' HAS BUS ',
     &            'name(s) not in system.  ltc ignored.')
           call prterx ('W',1)
        else
           ntttot = ntttot + 1
           itx(2,ntttot) = kt
           itx(3,ntttot) = mt
        endif
10520   continue
C
C  CONVERT TO INTERNAL BUS NUMBERS
C
        do 10530 i=1,ntttot
           kt = itx(2,i)
           mt = itx(3,i)
           itx(2,i) = inp2opt(kt)
           itx(3,i) = inp2opt(mt)
10530      continue
C
C  TEST FOR VALID LTC
C
        itxc = 1
C
C  INITIALIZE FIRST PASS - FOWARD TEST
C
10550   ipass = 1
        match = 0
        jrow = 0
        ltranc = 1
        itxpak = ipack_2 (itx(2,itxc), itx(3,itxc))
C
C  BEGIN LOOP
C
10560   ltrpak = ipack_2 (ltran(1,ltranc), ltran(9,ltranc))
        if ( itxpak - ltrpak .eq. 0 ) then
           match = 1
           jrow = ltranc
        endif
        ltranc = ltranc + 1
        if( match .eq. 0 ) then
C
C  TEST NEXT ROW IN LTRAN ARRAY
C
           if( ltranc .le. ntota ) go to 10560
C
C  INITIALIZE SECOND PASS - REVERSE TEST
C
           if( ipass .eq. 1 ) then
              ipass = 2
              ltranc = 1
              itxpak = ipack_2 (itx(2,itxc), itx(3,itxc))
              go to 10560
           endif
        endif
C
C  STORE LTC NUMBER IF VALID, OR FLAG WITH 0 IF NOT VALID
C  PROCESS NEXT ROW IN ITX ARRAY
C
        itx(1,itxc) = jrow
        itxc = itxc + 1
        if( itxc .le. ntttot ) go to 10550
C
C  ELIMINATE BAD LTC'S FROM ITX ARRAY
C
        ngood = 0
        do 10580 itxc = 1,ntttot
C
C  TEST FOR BAD LTC
C
        if( itx(1,itxc) .eq. 0 ) then
                kt = itx(2,itxc)
                mt = itx(3,itxc)
                write (errbuf(1),10570) intbus(kt),intbas(kt),
     1                  intbus(mt),intbas(mt)
10570           format('0 "TRACE_LTC" ',a8,f7.1,4x,a8,f7.1,
     1                  ' is not in system.  ltc ignored.')
                call prterx ('W',1)
           else
                ngood = ngood + 1
                itx(1,ngood) = itx(1,itxc)
           endif
10580   continue
        ntttot = ngood
C
C  ELIMINATE DUPLICATE LTC'S
C
        key=0
        call qiksrt(1,ntttot,kmplt,swplt)
        if (key.eq.0) go to 10640
        j=1
        k=2
10620   if(kmplt(j,k).lt.0) then
                j=j+1
                if(j.lt.k)call swplt(j,k)
                k=k+1
           else
                kt = itx(2,j)
                mt = itx(3,j)
                write (errbuf(1),10630) intbus(kt),intbas(kt),
     1                  intbus(mt),intbas(mt)
10630           format('0 DUPLICATE "TRACE_LTC" ',a8,f7.1,4x,
     1                  a8,f7.1,' . second item ignored.')
                call prterx ('I',1)
                k=k+1
           endif
        if(k.le.ntttot) go to 10620
        ntttot=j
C
C  ERROR IF NO VALID "TRACE_LTC" DATA REMAINS
C
10640   if( ntttot .eq. 0) then
                write (errbuf(1),10650)
10650           format('0 NO VALID LTC DATA FOLLOWS "TRACE_LTC" ',
     1                  'solution text.')
                call prterx ('W',1)
           endif
        go to 170
C
C     Process /GEN_DROP commands.
C
10700 call getdrp (dropmw, error)
      if (error .ne. 0) call erexit

      if (buf(1:1) .eq. '(') then
        islnsw = 0
        goto 1330
      else
        inptls = 1
        call sinput
        go to 170
      endif
C
C     END OF PROCESS-SOLUTION TEXT RECORDS.
C
 1330 continue
C
C     BUILD PERCENTAGE VAR CONTROL ARRAY "PCTVR"
C
      if (ntotb .gt .0) then
         call varint
      endif
C
C     INITIALIZE DC ARRAY
C
      if (kdtot .gt. 0 .or. mtdcbs .gt. 0) then
         call dcdata
      endif
      go to 1920

 1900 write (errbuf(1),1910) buf(1:50)
 1910 format ('0 DUPLICATE SOLUTION TEXT CARD  (', a, ')')
      call prterx ('W',1)
      call erexit

 1920 continue
      end


C
C	$Id: wmrgwt.f,v 1.9 2008-07-27 00:17:37 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE WMRGWT(N,X,Y,IFNT,NASC)
C
C  Fill the region given by coordinates (X(I),Y(I),I=1,N) with
C  character ICHR (an ASCII decimal equivalent) from font IFNT.
C
      include 'wmcomn.h'
C
C  The value of IDRFLG control how the clipped symbols are drawn.
C  The area is filled and then a representative line is drawn so
C  that the symbols do not disappear on low-resolution devices.
C
      COMMON /WMLGCM/IDRFLG
C
C  Parameters for apportioning work space.
C
      PARAMETER (MDGU=7000,MDGUH=MDGU/2,MDGUP1=MDGU+1,
     +           MDGUP=MDGU+MDGUH+1,MDGU2=2*MDGU,MDGU2P=MDGU2+1)
      DIMENSION X(N),Y(N)
      EXTERNAL WMLGFA
C
C  Check error status.
C
      IF (ICFELL('WMRGWT - Uncleared prior error',1) .NE. 0) RETURN
C
C  Find the extent of the specified region.
C
      XRL = X(1)
      XRR = X(1)
      YRB = Y(1)
      YRT = Y(1)
      DO 10 I=2,N
        XRL = MIN(XRL,X(I))
        YRB = MIN(YRB,Y(I))
        XRR = MAX(XRR,X(I))
        YRT = MAX(YRT,Y(I))
   10 CONTINUE
C
C  Get the digitization of the character.
C
      IPSS = 2
      IBNU = 3
      CALL PCCFFF (IPSS,IBNU,IFNT,NASC,WSIZER,WSIZER,RWORK,MDGU,NDGU)
C
C  Set up character width and height, depending on the character
C  being drawn.  IOFFLG flags whether the characters should be
C  offset from row-to-row, and ROFFLG specifies how much to offset.
C
      IF (IFNT.EQ.37 .AND. NASC.EQ.101) THEN
C
C    Showers.
        WIDSCL = 1.20
        CHRWID = WIDSCL*(RWORK(2)-RWORK(1))
        CHRHIT = 1.60*WSIZER
        IDRFLG = 1
        IOFFLG = 0
        ROFFLG = 0.
        SSCALE = 1.
      ELSE IF (IFNT.EQ.37 .AND. NASC.EQ.102) THEN
C
C    T-storms.
        WIDSCL = 1.90
        CHRWID = WIDSCL*(RWORK(2)-RWORK(1))
        CHRHIT = 1.60*WSIZER
        IDRFLG = 2
        IOFFLG = 0
        ROFFLG = 0.
        SSCALE = 1.
      ELSE IF (IFNT.EQ.37 .AND. NASC.EQ.103) THEN
C
C    Rain
        WIDSCL = 2.25
        CHRWID = WIDSCL*(RWORK(2)-RWORK(1))
        CHRHIT = 1.00*WSIZER
        IDRFLG = 3
        IOFFLG = 1
        ROFFLG = 0.5
        SSCALE = 1.
      ELSE IF (IFNT.EQ.37 .AND. NASC.EQ.106) THEN
C
C    Flurries.
        WIDSCL = 2.00
        CHRWID = WIDSCL*(RWORK(2)-RWORK(1))
        CHRHIT = 1.10*WSIZER
        IDRFLG = 3
        IOFFLG = 1
        ROFFLG = 0.4
        SSCALE = 1.
      ELSE IF (IFNT.EQ.37 .AND. NASC.EQ.104) THEN
C
C    Snow.
        WIDSCL = 2.20
        CHRWID = WIDSCL*(RWORK(2)-RWORK(1))
        CHRHIT = 1.37*WSIZER
        IDRFLG = 3
        IOFFLG = 1
        ROFFLG = 0.5
        SSCALE = 1.33
      ELSE IF (IFNT.EQ.37 .AND. NASC.EQ.105) THEN
C
C    Ice.
        WIDSCL = 1.40
        CHRWID = WIDSCL*(RWORK(2)-RWORK(1))
        CHRHIT = 0.7*WSIZER
        IDRFLG = 4
        IOFFLG = 1
        ROFFLG = 0.35
        SSCALE = 1.33
C
      ELSE
        WIDSCL = 1.00
        CHRWID = RWORK(2)-RWORK(1)
        CHRHIT = WSIZER
        IDRFLG = 3
        IOFFLG = 0
        ROFFLG = 0.
        SSCALE = 1.0
      ENDIF
C
C  Sweep across the region from top to bottom.  Set the value for
C  IDRFLG so that outlines are drawn to prevent small filled areas
C  from dropping out on low-resolution screens.
C
      SEEDX = XRL+0.5*CHRWID/WIDSCL
      SEEDY = YRT-0.5*CHRHIT
      LXEXT = ((XRR-XRL)/CHRWID)+2
      LYEXT = ((YRT-YRB)/CHRHIT)+2
      DO 20 J=1,LYEXT
        YP = SEEDY-(J-1)*CHRHIT
        DO 30 I=1,LXEXT
          XP = SEEDX+(I-1)*CHRWID-
     +           REAL(MOD(J-1,2))*REAL(IOFFLG)*ROFFLG*CHRWID
          L = 1
            K = 0
   60       CONTINUE
            L = L+2
            IF (L .GT. NDGU) GO TO 70
              K = K+1
              IF (RWORK(L).EQ.-2047.) THEN
                CALL PPINPO(X,Y,N,RWORK(MDGUP1),RWORK(MDGUP),
     +                      K-1,RWORK(MDGU2P),IWORK(MDGU2P),
     +                      NWRK-MDGU2,WMLGFA,IER)
C
C  Ignore degenerate areas.
C
                IF (IER.NE.0 .AND. IER.NE.2) THEN
                  CALL SETER (
     +              'WMRGWT - error calculating area intersection',
     +               1, 1)
                  RETURN
                ENDIF
                K = 0
              ELSE IF (RWORK(L).EQ.-2048.) THEN
C
C  Install a line clipper in here when it becomes available.
C
                IDRFLG = -1
                CALL PPINPO(X,Y,N,RWORK(MDGUP1),RWORK(MDGUP),
     +                      K-1,RWORK(MDGU2P),IWORK(MDGU2P),
     +                      NWRK-MDGU2,WMLGFA,IER)
C
C  Ignore degenerate areas.
C
                IF (IER.NE.0 .AND. IER.NE.2) THEN
                  CALL SETER (
     +              'WMRGWT - error calculating area intersection',
     +               1, 1)
                  RETURN
                ENDIF
                K = 0
              ELSE
                RWORK(K+MDGU)       = XP+SSCALE*RWORK(L)
                RWORK(K+MDGU+MDGUH) = YP+SSCALE*RWORK(L+1)
              ENDIF
            GO TO 60
   70     CONTINUE
   30   CONTINUE
   20 CONTINUE
C
      RETURN
      END