!=======================================================================
! Generated by  : PSCAD v4.6.3.0
!
! Warning:  The content of this file is automatically generated.
!           Do not modify, as any changes made here will be lost!
!-----------------------------------------------------------------------
! Component     : Main
! Description   :
!-----------------------------------------------------------------------

!=======================================================================

      SUBROUTINE MainDyn()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 'emtstor.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's2.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'fnames.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'matlab.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Subroutine Arguments

! Electrical Node Indices

! Control Signals
      INTEGER  BRK, BRK_STAT
      REAL     V1, V2, V3, Ishort, I30, I20, I12
      REAL     V34, V4, V5, Ibrk

! Internal Variables
      INTEGER  IVD1_1, IVD1_2
      REAL     RVD1_1, RVD1_2, RVD1_3, RVD1_4

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER ISTOI, ISTOF, IT_0                  ! Storage Indices
      INTEGER IPGB                                ! Control/Monitoring
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Dsdyn <-> Dsout transfer index storage

      NTXFR = NTXFR + 1

      TXFR(NTXFR,1) = NSTOL
      TXFR(NTXFR,2) = NSTOI
      TXFR(NTXFR,3) = NSTOF
      TXFR(NTXFR,4) = NSTOC

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      ISTOI     = NSTOI
      NSTOI     = NSTOI + 2
      ISTOF     = NSTOF
      NSTOF     = NSTOF + 11
      IPGB      = NPGB
      NPGB      = NPGB + 12
      INODE     = NNODE + 2
      NNODE     = NNODE + 8
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 9
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Transfers from storage arrays
!---------------------------------------

      V1       = STOF(ISTOF + 1)
      V2       = STOF(ISTOF + 2)
      V3       = STOF(ISTOF + 3)
      Ishort   = STOF(ISTOF + 4)
      I30      = STOF(ISTOF + 5)
      I20      = STOF(ISTOF + 6)
      I12      = STOF(ISTOF + 7)
      V34      = STOF(ISTOF + 8)
      V4       = STOF(ISTOF + 9)
      V5       = STOF(ISTOF + 10)
      BRK      = STOI(ISTOI + 1)
      BRK_STAT = STOI(ISTOI + 2)
      Ibrk     = STOF(ISTOF + 11)

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

!---------------------------------------
! Configuration of Models
!---------------------------------------

      IF ( TIMEZERO ) THEN
         FILENAME = 'Main.dta'
         CALL EMTDC_OPENFILE
         SECTION = 'DATADSD:'
         CALL EMTDC_GOTOSECTION
      ENDIF
!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 10:[tbreakn] Timed Breaker Logic
! Timed breaker logic
      IF ( TIMEZERO ) THEN
         BRK = 0
      ELSE
         BRK = 0
         IF ( TIME .GE. 0.06667 ) BRK = (1-0)
      ENDIF

! 80:[breaker1] Single Phase Breaker 'BRK'
      IVD1_2 = NSTORI
      NSTORI = NSTORI + 1
      CALL E1PBRKR1_EXE(SS, (IBRCH+6),1.0e-06,1000000.0,0,NINT(1.0-REAL(&
     &BRK)))
      IVD1_1 = 2*E_BtoI(OPENBR( (IBRCH+6),SS))
      IF (FIRSTSTEP .OR. (STORI(IVD1_2) .NE. IVD1_1)) THEN
         CALL PSCAD_AGI2(ICALL_NO,189360772,IVD1_1,"BOpen")
      ENDIF
      STORI(IVD1_2) = 2*E_BtoI(OPENBR( (IBRCH+6),SS))
      BRK_STAT = IVD1_1

! 240:[pgb] Output Channel 'BRK_STAT'

      PGB(IPGB+11) = REAL(BRK_STAT)

! 1:[source_1] Single Phase Voltage Source Model 2 'vs'
!  Single Phase AC source: Type: Ideal
      RVD1_1 = RTCF(NRTCF)
      RVD1_2 = RTCF(NRTCF+1)
      RVD1_3 = RTCF(NRTCF+2)
      RVD1_4 = RTCF(NRTCF+3)
      NRTCF = NRTCF + 4
      CALL EMTDC_1PVSRC(SS, (IBRCH+1),RVD1_4,1,RVD1_1,RVD1_2,RVD1_3)

!---------------------------------------
! Feedbacks and transfers to storage
!---------------------------------------

      STOF(ISTOF + 1) = V1
      STOF(ISTOF + 2) = V2
      STOF(ISTOF + 3) = V3
      STOF(ISTOF + 4) = Ishort
      STOF(ISTOF + 5) = I30
      STOF(ISTOF + 6) = I20
      STOF(ISTOF + 7) = I12
      STOF(ISTOF + 8) = V34
      STOF(ISTOF + 9) = V4
      STOF(ISTOF + 10) = V5
      STOI(ISTOI + 1) = BRK
      STOI(ISTOI + 2) = BRK_STAT
      STOF(ISTOF + 11) = Ibrk

!---------------------------------------
! Transfer to Exports
!---------------------------------------

!---------------------------------------
! Close Model Data read
!---------------------------------------

      IF ( TIMEZERO ) CALL EMTDC_CLOSEFILE
      RETURN
      END

!=======================================================================

      SUBROUTINE MainOut()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 'emtstor.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's2.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'fnames.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'matlab.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

      REAL    EMTDC_VVDC    !
      REAL    VBRANCH       !

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Electrical Node Indices
      INTEGER  NT_1, NT_2, NT_6, NT_7, NT_9
      INTEGER  NT_10

! Control Signals
      REAL     V1, V2, V3, Ishort, I30, I20, I12
      REAL     V34, V4, V5, Ibrk

! Internal Variables

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER ISTOL, ISTOI, ISTOF, ISTOC, IT_0    ! Storage Indices
      INTEGER IPGB                                ! Control/Monitoring
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Dsdyn <-> Dsout transfer index storage

      NTXFR = NTXFR + 1

      ISTOL = TXFR(NTXFR,1)
      ISTOI = TXFR(NTXFR,2)
      ISTOF = TXFR(NTXFR,3)
      ISTOC = TXFR(NTXFR,4)

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      IPGB      = NPGB
      NPGB      = NPGB + 12
      INODE     = NNODE + 2
      NNODE     = NNODE + 8
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 9
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Transfers from storage arrays
!---------------------------------------

      V1       = STOF(ISTOF + 1)
      V2       = STOF(ISTOF + 2)
      V3       = STOF(ISTOF + 3)
      Ishort   = STOF(ISTOF + 4)
      I30      = STOF(ISTOF + 5)
      I20      = STOF(ISTOF + 6)
      I12      = STOF(ISTOF + 7)
      V34      = STOF(ISTOF + 8)
      V4       = STOF(ISTOF + 9)
      V5       = STOF(ISTOF + 10)
      Ibrk     = STOF(ISTOF + 11)

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

      NT_1  = NODE(INODE + 1)
      NT_2  = NODE(INODE + 2)
      NT_6  = NODE(INODE + 3)
      NT_7  = NODE(INODE + 4)
      NT_9  = NODE(INODE + 5)
      NT_10 = NODE(INODE + 6)

!---------------------------------------
! Configuration of Models
!---------------------------------------

      IF ( TIMEZERO ) THEN
         FILENAME = 'Main.dta'
         CALL EMTDC_OPENFILE
         SECTION = 'DATADSO:'
         CALL EMTDC_GOTOSECTION
      ENDIF
!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 20:[voltmetergnd] Voltmeter (Line - Ground) 'V1'
      V1 = EMTDC_VVDC(SS, NT_1, 0)

! 30:[voltmetergnd] Voltmeter (Line - Ground) 'V2'
      V2 = EMTDC_VVDC(SS, NT_2, 0)

! 40:[ammeter] Current Meter 'I12'
      I12 = ( CBR((IBRCH+3), SS))

! 50:[voltmetergnd] Voltmeter (Line - Ground) 'V3'
      V3 = EMTDC_VVDC(SS, NT_9, 0)

! 60:[ammeter] Current Meter 'Ibrk'
      Ibrk = ( CBR((IBRCH+2), SS))

! 70:[voltmeter] Voltmeter (Line - Line) 'V34'
      V34 = EMTDC_VVDC(SS, NT_10, NT_6)

! 80:[breaker1] Single Phase Breaker 'BRK'
! Single phase breaker current
!

! 90:[voltmetergnd] Voltmeter (Line - Ground) 'V4'
      V4 = EMTDC_VVDC(SS, NT_6, 0)

! 100:[pgb] Output Channel 'V1'

      PGB(IPGB+1) = V1

! 110:[voltmetergnd] Voltmeter (Line - Ground) 'V5'
      V5 = EMTDC_VVDC(SS, NT_7, 0)

! 120:[ammeter] Current Meter 'I20'
      I20 = (-CBR((IBRCH+4), SS))

! 130:[ammeter] Current Meter 'I30'
      I30 = (-CBR((IBRCH+5), SS))

! 140:[pgb] Output Channel 'V2'

      PGB(IPGB+2) = V2

! 150:[ammeter] Current Meter 'Ishort'
      Ishort = ( CBR((IBRCH+7), SS))

! 160:[pgb] Output Channel 'V3'

      PGB(IPGB+3) = V3

! 170:[pgb] Output Channel 'V34'

      PGB(IPGB+4) = V34

! 180:[pgb] Output Channel 'V4'

      PGB(IPGB+5) = V4

! 190:[pgb] Output Channel 'V5'

      PGB(IPGB+6) = V5

! 200:[pgb] Output Channel 'Ishort'

      PGB(IPGB+7) = Ishort

! 210:[pgb] Output Channel 'I30'

      PGB(IPGB+8) = I30

! 220:[pgb] Output Channel 'I20'

      PGB(IPGB+9) = I20

! 230:[pgb] Output Channel 'I12'

      PGB(IPGB+10) = I12

! 250:[pgb] Output Channel 'Ibrk'

      PGB(IPGB+12) = Ibrk

!---------------------------------------
! Feedbacks and transfers to storage
!---------------------------------------

      STOF(ISTOF + 1) = V1
      STOF(ISTOF + 2) = V2
      STOF(ISTOF + 3) = V3
      STOF(ISTOF + 4) = Ishort
      STOF(ISTOF + 5) = I30
      STOF(ISTOF + 6) = I20
      STOF(ISTOF + 7) = I12
      STOF(ISTOF + 8) = V34
      STOF(ISTOF + 9) = V4
      STOF(ISTOF + 10) = V5
      STOF(ISTOF + 11) = Ibrk

!---------------------------------------
! Close Model Data read
!---------------------------------------

      IF ( TIMEZERO ) CALL EMTDC_CLOSEFILE
      RETURN
      END

!=======================================================================

      SUBROUTINE MainDyn_Begin()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Subroutine Arguments

! Electrical Node Indices

! Control Signals

! Internal Variables

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER IT_0                                ! Storage Indices
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      INODE     = NNODE + 2
      NNODE     = NNODE + 8
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 9
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 80:[breaker1] Single Phase Breaker 'BRK'
      CALL COMPONENT_ID(ICALL_NO,189360772)
      CALL E1PBRKR1_CFG(1.0e-06,1000000.0,0.0)

! 240:[pgb] Output Channel 'BRK_STAT'

! 1:[source_1] Single Phase Voltage Source Model 2 'vs'
      CALL E_1PVSRC_CFG(1,0,6,163.0,60.0,90.0,0.0,0.0,0.0,0.0,0.0,0.0)

      RETURN
      END

!=======================================================================

      SUBROUTINE MainOut_Begin()

!---------------------------------------
! Standard includes
!---------------------------------------

      INCLUDE 'nd.h'
      INCLUDE 'emtconst.h'
      INCLUDE 's0.h'
      INCLUDE 's1.h'
      INCLUDE 's4.h'
      INCLUDE 'branches.h'
      INCLUDE 'pscadv3.h'
      INCLUDE 'radiolinks.h'
      INCLUDE 'rtconfig.h'

!---------------------------------------
! Function/Subroutine Declarations
!---------------------------------------

!---------------------------------------
! Variable Declarations
!---------------------------------------

! Subroutine Arguments

! Electrical Node Indices
      INTEGER  NT_1, NT_2, NT_6, NT_7, NT_9
      INTEGER  NT_10

! Control Signals

! Internal Variables

! Indexing variables
      INTEGER ICALL_NO                            ! Module call num
      INTEGER IT_0                                ! Storage Indices
      INTEGER SS, INODE, IBRCH                    ! SS/Node/Branch/Xfmr

!---------------------------------------
! Local Indices
!---------------------------------------

! Define electric network subsystem number

      SS        = NODE(NNODE+1)

! Increment and assign runtime configuration call indices

      ICALL_NO  = NCALL_NO
      NCALL_NO  = NCALL_NO + 1

! Increment global storage indices

      INODE     = NNODE + 2
      NNODE     = NNODE + 8
      IBRCH     = NBRCH(SS)
      NBRCH(SS) = NBRCH(SS) + 9
      NCSCS     = NCSCS + 0
      NCSCR     = NCSCR + 0

!---------------------------------------
! Electrical Node Lookup
!---------------------------------------

      NT_1  = NODE(INODE + 1)
      NT_2  = NODE(INODE + 2)
      NT_6  = NODE(INODE + 3)
      NT_7  = NODE(INODE + 4)
      NT_9  = NODE(INODE + 5)
      NT_10 = NODE(INODE + 6)

!---------------------------------------
! Generated code from module definition
!---------------------------------------

! 100:[pgb] Output Channel 'V1'

! 140:[pgb] Output Channel 'V2'

! 160:[pgb] Output Channel 'V3'

! 170:[pgb] Output Channel 'V34'

! 180:[pgb] Output Channel 'V4'

! 190:[pgb] Output Channel 'V5'

! 200:[pgb] Output Channel 'Ishort'

! 210:[pgb] Output Channel 'I30'

! 220:[pgb] Output Channel 'I20'

! 230:[pgb] Output Channel 'I12'

! 250:[pgb] Output Channel 'Ibrk'

      RETURN
      END


      subroutine readdata
      use momentheader

      real*8, allocatable :: ch1(:)
      real*8, allocatable :: d1(:,:),q1(:,:,:),o1(:,:,:,:),h1(:,:,:,:,:)

      character*20 ca,ca1

      bohr=1.d0/1.8897259886d0

      allocate(ch1(natom))
      allocate(d1(natom,3))
      allocate(q1(natom,3,3))
      allocate(o1(natom,3,3,3))
      allocate(h1(natom,3,3,3,3))

c read in the electrostatic data for nL1 frags
      do n=1,nL1
       call filelabel(n,ca)
       n1=index(ca,' ')-1
       ca1='nb.'//ca(1:n1)//'.0.cart'
       open(unit=1,file=ca1,status='old')
       read(1,*)
       read(1,*)natom1
       do i=1,natom1
        read(1,*)
        do k=1,3
         read(1,*)c1
c convert to Bohr
        enddo
        read(1,*)
        read(1,*)ch1(i)
        read(1,*)
        do k=1,3
         read(1,*)d1(i,k)
        enddo
        read(1,*)
        do k1=1,3
        do k2=k1,3
        read(1,*)q1(i,k1,k2)
        enddo
        enddo
        read(1,*)
        do k1=1,3
        do k2=k1,3
        do k3=k2,3
        read(1,*)o1(i,k1,k2,k3)
        enddo
        enddo
        enddo
        read(1,*)
        do k1=1,3
        do k2=k1,3
        do k3=k2,3
        do k4=k3,3
        read(1,*)h1(i,k1,k2,k3,k4)
        enddo
        enddo
        enddo
        enddo
c        call symm(q1(i,:,:),o1(i,:,:,:),h1(i,:,:,:,:))
c end the i loop
       enddo
       close(unit=1)
c assign to real atoms
       do i=1,nat1(n)
       do j=1,num1(n,i)
       ch(natnum1(n,i,j))=ch(natnum1(n,i,j))+isign(n)*ch1(i)*w1(n,i,j)
       do k1=1,3
       d(natnum1(n,i,j),k1)=d(natnum1(n,i,j),k1)+
     .      isign(n)*d1(i,k1)*w1(n,i,j)
       do k2=k1,3
       q(natnum1(n,i,j),k1,k2)=q(natnum1(n,i,j),k1,k2)+
     .      isign(n)*q1(i,k1,k2)*w1(n,i,j)
       do k3=k2,3
       o(natnum1(n,i,j),k1,k2,k3)=o(natnum1(n,i,j),k1,k2,k3)+
     .      isign(n)*o1(i,k1,k2,k3)*w1(n,i,j)
       do k4=k3,3
       h(natnum1(n,i,j),k1,k2,k3,k4)=h(natnum1(n,i,j),k1,k2,k3,k4)+
     .      isign(n)*h1(i,k1,k2,k3,k4)*w1(n,i,j)
       enddo
       enddo
       enddo
       enddo
       enddo
       enddo

c end the n loop
      enddo

c     do n=1,natom
c      call symm(q(n,:,:),o(n,:,:,:),h(n,:,:,:,:))
c     enddo

      deallocate(d1)
      deallocate(q1)
      deallocate(o1)
      deallocate(h1)

      return
      end


! This code may (or may not) be part of the COAMPS distribution,
! So it is not protected by the DART copyright agreement.
!
! DART $Id$

program perturb_init

! This program pulls pieces out of the large COAMPS restart file,
! then assembles them into a state vector that can be used by DART.
! This includes two pieces of information - the current time and
! the actual state

  use coamps_nest_mod,      only : coamps_nest,                  &
                                   initialize_nest,              &
                                   set_nest_id,                  &
                                   get_nest_i_width,             &
                                   get_nest_j_width

  use coamps_vertical_mod,  only : coamps_vertical,              &
                                   initialize_vertical,          &
                                   get_num_levels,               &
                                   get_msigma,                   &
                                   get_wsigma

  use coamps_util_mod,      only : check_alloc_status,           &
                                   check_dealloc_status,         &
                                   check_io_status,              &
                                   generate_flat_file_name,      &
                                   read_flat_file,               &
                                   write_flat_file,              &
                                   read_datahd_file,             &
                                   DATAHD_LEN

  use utilities_mod,        only : E_ERR,                        &
                                   error_handler,                &
                                   file_exist,                   &
                                   get_unit

  use random_seq_mod, only: random_seq_type, &
                            init_random_seq, &
                            random_gaussian, &
                            random_uniform

  use types_mod,            only : r8, r4

  implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

  character(len=*), parameter :: routine = 'perturb_init'
  character(len=64)           :: coamps_file_name
  character(len=64)           :: coamps_new_file_name

  character(len=64)           :: coamps_init_pert
  character(len=64)           :: coamps_init_file

  integer, parameter :: nflds = 5

  character(len=6), dimension(nflds), parameter :: &
  bndy_fldnames=(/'bduwnd', 'bdvwnd', 'bdpott', 'bdperp', 'bdmixr'/)

  character(len=6), dimension(nflds), parameter :: &
  full_fldnames=(/'uuwind', 'vvwind', 'pottmp', 'perprs', 'wvapor'/)

  character(len=*),  parameter :: nml_file = 'pert_init.nml'
  integer,           parameter :: maxgrds  = 7
  integer,           parameter :: NEST_ID  = 1
  integer,           parameter :: SECPERHR = 3600
  character(len=10), parameter :: dtg_pert = '0000000000'

  integer                      :: current_mem
  integer                      :: xpts
  integer                      :: ypts
  integer                      :: gridnum
  character(len=6)             :: fldname

  real(kind=r8)                :: alpha       = 0.75_r8
  real(kind=r8)                :: fcp_scale   = 1.75_r8
  integer                      :: ens_size    = 10
  integer                      :: npert_tot   = 400
  integer                      :: kgetbc      = 6
  integer, dimension(3,maxgrds):: ktauf = &
  reshape( (/6,0,0,6,0,0,6,0,0,6,0,0,6,0,0,6,0,0,6,0,0/),(/3,maxgrds/))
  integer                      :: nbdypt      = 7
  character(len=10)            :: cdtg        = '1970010100'
  character(len=80)            :: dsnrff      ='./'
  character(len=80)            :: dsnrff_pert ='./'

  namelist /pert_init/ alpha, fcp_scale, ens_size, npert_tot, nbdypt, &
                       cdtg, dsnrff, dsnrff_pert, kgetbc, ktauf

  real(kind=r8), allocatable :: xpert(:)
  real(kind=r8), allocatable :: xpert_m1(:)
  real(kind=r8), allocatable :: xinit(:)
  integer,       allocatable :: ipert_nums(:, :)

  integer            :: file_unit
  integer            :: nml_unit

  integer            :: io_status
  character(len=5)   :: fileaction
  character(len=7)   :: filestatus

  integer :: fieldsize
  integer :: filesize
  integer :: r4_length

  real(kind=r8), dimension(DATAHD_LEN) :: coamps_datahd

  type(random_seq_type) :: random_sequence
  type(coamps_nest)     :: static_nest
  type(coamps_vertical) :: static_vgrid

  integer               :: rand_seq_seed
  integer               :: nx, ny, nz, nt
  integer               :: ii, nn, tt, ipert, tau_hr
  real(kind=r8)         :: ztop, zbot

!------------------------------------------------------------------------------
! initialize variables
!------------------------------------------------------------------------------

  inquire(IOLENGTH=r4_length) 0_r4
  file_unit = get_unit()
  nml_unit  = get_unit()

  print '(A)', 'Enter the ensemble member: '
  read(*, *) current_mem
!------------------------------------------------------------------------------
! Read namelist data
!------------------------------------------------------------------------------
  if (file_exist(nml_file)) then
    open(nml_unit, file=nml_file, status='old', iostat=io_status)
    call check_io_status(io_status, routine, source, revision, revdate,   &
                        'Opening ' // nml_file)

    read(nml_unit, nml=pert_init,   iostat=io_status)
    call check_io_status(io_status, routine, source, revision, revdate, &
                        'Reading ' // nml_file // ' pert_init')
    close(nml_unit)
  else
    call error_handler(E_ERR, 'recntr_initperts', 'compute_mean name' // &
                      'list read failed - target file not found',       &
                       source, revision, revdate)
  end if

!------------------------------------------------------------------------------
! Read data header file and set sizes
!------------------------------------------------------------------------------
  call read_datahd_file(cdtg, coamps_datahd)
  call initialize_vertical(coamps_datahd, static_vgrid)

  call set_nest_id(static_nest, NEST_ID)
  call initialize_nest(static_nest, cdtg, coamps_datahd)

  gridnum = 1
  !nt = ktauf(1, NEST_ID)/kgetbc + 1
  nt = 1
  nx = get_nest_i_width(static_nest)
  ny = get_nest_j_width(static_nest)
  !fieldsize = nx*nbdypt*2 + (ny - nbdypt*2) * nbdypt*2
  fieldsize = nx*ny

!------------------------------------------------------------------------------
! Initialize and set random sequence. Integer seed based on dtg.
!------------------------------------------------------------------------------
  read(cdtg(3:10),'(I8)') rand_seq_seed
  rand_seq_seed=-rand_seq_seed
  call init_random_seq(r=random_sequence, seed=rand_seq_seed)

  allocate(ipert_nums(ens_size, nt))
  do tt=1,nt
    do ii=1,ens_size
      !ipert_nums(ii, tt) = ceiling(random_uniform(random_sequence) * real(npert_tot, kind=r8))
      ipert_nums(ii, tt) = ii
    end do
  end do

!------------------------------------------------------------------------------
! Loop over all fields
!------------------------------------------------------------------------------
  VAR_LOOP : do nn=1,nflds
    fldname = full_fldnames(nn)

    print '(3(A,1x),I3.3)','Perturbing',fldname,'for member',current_mem

    select case(fldname)
    case('bdwwnd', 'wwwind')
      nz = get_num_levels(static_vgrid) + 1
      ztop = get_wsigma(static_vgrid,  1)
      zbot = get_wsigma(static_vgrid, nz)
    case default
      nz = get_num_levels(static_vgrid)
      ztop = get_msigma(static_vgrid,  1)
      zbot = get_msigma(static_vgrid, nz)
    end select

    allocate(xinit(nz*fieldsize))
    allocate(xpert(nz*fieldsize))
    allocate(xpert_m1(nz*fieldsize))

    filesize=r4_length*nz*fieldsize

   TIME_LOOP : do tt=1,nt

    fileaction = 'read'
    filestatus = 'old'

    tau_hr = (tt-1)*kgetbc
!------------------------------------------------------------------------------
! Read all perts and compute mean.
!------------------------------------------------------------------------------
    xinit(:) = 0.0_r8
    xpert(:) = 0.0_r8

    xpts = nx ; ypts = ny

    PERT_LOOP : do ii=1,ens_size
      ipert = ipert_nums(ii, tt)

      call generate_flat_file_name( var_name   = fldname,      &
                                    level_type = 'sig',         &
                                    level1     = int(ztop),     &
                                    level2     = int(zbot),     &
                                    gridnum    = gridnum,       &
                                    aoflag     = 'a',           &
                                    xpts       = xpts,          &
                                    ypts       = ypts,          &
                                    dtg        = dtg_pert,      &
                                    tau_hh     = ipert,         &
                                    tau_mm     = 0,             &
                                    tau_ss     = 0,             &
                                    field_type = 'pertfld',     &
                                    file_name  = coamps_init_pert )

      open( unit=file_unit,                                         &
            file=trim(dsnrff_pert)//coamps_init_pert,               &
            status=filestatus, access='direct', action=fileaction,  &
            form='unformatted', recl=filesize, iostat=io_status)
      call check_io_status(io_status, routine, source, revision,    &
                           revdate, 'Opening ' //                   &
                           coamps_init_pert // ' for read')

      call read_flat_file(file_unit, xpert)
      close(file_unit)

      xinit(:) = xinit(:) + xpert(:)/real(ens_size, kind=r8)

    end do PERT_LOOP

!------------------------------------------------------------------------------
! Read perturbation for this member and recenter around zero mean.
!------------------------------------------------------------------------------
    ipert = ipert_nums(current_mem, tt)

    xpts = nx ; ypts = ny
    !xpts = fieldsize ; ypts = nz

    call generate_flat_file_name( var_name   = fldname,  &
                                  level_type = 'sig',         &
                                  level1     = int(ztop),     &
                                  level2     = int(zbot),     &
                                  gridnum    = gridnum,       &
                                  aoflag     = 'a',           &
                                  xpts       = xpts,          &
                                  ypts       = ypts,          &
                                  dtg        = dtg_pert,      &
                                  tau_hh     = ipert,         &
                                  tau_mm     = 0,             &
                                  tau_ss     = 0,             &
                                  field_type = 'pertfld',     &
                                  file_name  = coamps_init_pert )

    open( unit=file_unit,                                         &
          file=trim(dsnrff_pert)//coamps_init_pert,               &
          status=filestatus, access='direct', action=fileaction,  &
          form='unformatted', recl=filesize, iostat=io_status)
    call check_io_status(io_status, routine, source, revision,    &
                         revdate, 'Opening ' //                   &
                         coamps_init_pert // ' for read')

    call read_flat_file(file_unit, xpert)
    close(file_unit)

    xpert(:) = xpert(:) - xinit(:)

!------------------------------------------------------------------------------
! Read deterministic fields.
!------------------------------------------------------------------------------
    xpts = nx ; ypts = ny
    !xpts = fieldsize ; ypts = nz

    call generate_flat_file_name( var_name   = fldname,  &
                                  level_type = 'sig',         &
                                  level1     = int(ztop),     &
                                  level2     = int(zbot),     &
                                  gridnum    = gridnum,       &
                                  aoflag     = 'a',           &
                                  xpts       = xpts,          &
                                  ypts       = ypts,          &
                                  dtg        = cdtg,          &
                                  tau_hh     = tau_hr,        &
                                  tau_mm     = 0,             &
                                  tau_ss     = 0,             &
                                  field_type = 'analfld',     &
                                  file_name  = coamps_init_file )

    open( unit=file_unit,                                         &
          file=trim(dsnrff)//'analyses/'//coamps_init_file,       &
          status=filestatus, access='direct', action=fileaction,  &
          form='unformatted', recl=filesize, iostat=io_status)
    call check_io_status(io_status, routine, source, revision,    &
                         revdate, 'Opening ' //                   &
                         coamps_init_file // ' for read')

    call read_flat_file(file_unit, xinit)
    close(file_unit)

!------------------------------------------------------------------------------
! Perturb boundaries condition based on Torn et al MWR 2006.
! For tau_hr=0 perturb the mean field, for all other perturb the tendencies.
!------------------------------------------------------------------------------
    !if(tau_hr == 0) then
       xinit(:) = xinit(:) + xpert(:)
    !else
    !   xpert(:) = alpha * xpert_m1(:) + sqrt(1.0_r8 - alpha**2) * xpert(:)
    !   xinit(:) = xinit(:) + (xpert(:) - xpert_m1(:))/real(kgetbc*SECPERHR, kind=r8)
    !end if
    !xpert_m1(:) = xpert(:)

!------------------------------------------------------------------------------
! Write perturbed boundary to file
!------------------------------------------------------------------------------
    fileaction = 'write'
    filestatus = 'unknown'
    open( unit=file_unit,                                         &
          file=trim(dsnrff)//'analyses/'//coamps_init_file,       &
          status=filestatus, access='direct', action=fileaction,  &
          form='unformatted', recl=filesize, iostat=io_status)
    call check_io_status(io_status, routine, source, revision,    &
                         revdate, 'Opening ' //                   &
                         coamps_init_file // ' for write')
    call write_flat_file(file_unit, xinit)
    close(file_unit)

  end do TIME_LOOP

  deallocate(xinit)
  deallocate(xpert)
  deallocate(xpert_m1)

  end do VAR_LOOP

  deallocate(ipert_nums)

end program perturb_init

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!-----------------------------------------------------------------------
!     Subroutine:    torlines_write
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          06/9/2015
!     Description:   This subroutine writes out the fieldline data
!-----------------------------------------------------------------------
      SUBROUTINE torlines_write(write_type)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE torlines_fieldlines
      USE torlines_background
      USE torlines_realspace
      USE torlines_runtime
      USE torlines_write_par
      USE ez_hdf5
      USE mpi_params
      USE mpi_inc
!-----------------------------------------------------------------------
!     Input Variables
!          write_type  Type of write to preform
!-----------------------------------------------------------------------
      IMPLICIT NONE
      CHARACTER(*), INTENT(IN):: write_type
!-----------------------------------------------------------------------
!     Local Variables
!          ierr        Error flag
!-----------------------------------------------------------------------
      INTEGER :: ier
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      ier = 0
      SELECT CASE (TRIM(write_type))
         CASE('GRID_INIT')
            IF (myworkid == master) THEN
               CALL open_hdf5('torlines_'//TRIM(id_string)//'.h5',fid,ier,LCREATE=.true.)
               IF (ier /= 0) CALL handle_err(HDF5_OPEN_ERR,'torlines_'//TRIM(id_string)//'.h5',ier)
               CALL write_scalar_hdf5(fid,'VERSION',ier,DBLVAR=TORLINES_VERSION,ATT='Version Number',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'VERSION',ier)
               CALL write_scalar_hdf5(fid,'lvmec',ier,BOOVAR=lvmec,ATT='VMEC input',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'lvmec',ier)
               CALL write_scalar_hdf5(fid,'lpies',ier,BOOVAR=lpies,ATT='PIES input',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'lpies',ier)
               CALL write_scalar_hdf5(fid,'lspec',ier,BOOVAR=lspec,ATT='SPEC input',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'lspec',ier)
               CALL write_scalar_hdf5(fid,'lcoil',ier,BOOVAR=lcoil,ATT='Coil input',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'lcoil',ier)
               CALL write_scalar_hdf5(fid,'lmgrid',ier,BOOVAR=lmgrid,ATT='MGRID input',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'lmgrid',ier)
               CALL write_scalar_hdf5(fid,'lvac',ier,BOOVAR=lvac,ATT='Vacuum calc',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'lvac',ier)
               CALL write_scalar_hdf5(fid,'nrho',ier,INTVAR=nrho,ATT='Number of Rho Gridpoints',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'nrho',ier)
               CALL write_scalar_hdf5(fid,'nu',ier,INTVAR=nu,ATT='Number of Poloidal Gridpoints',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'nu',ier)
               CALL write_scalar_hdf5(fid,'nv',ier,INTVAR=nv,ATT='Number of Toroidal Gridpoints',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'nv',ier)
               CALL write_scalar_hdf5(fid,'nfp',ier,INTVAR=nfp,ATT='Number of Field Periods',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'nfp',ier)
               CALL write_var_hdf5(fid,'rreal',nrho,nu,nv,ier,DBLVAR=rreal,ATT='R Gridpoints',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'rreal',ier)
               CALL write_var_hdf5(fid,'zreal',nrho,nu,nv,ier,DBLVAR=zreal,ATT='Z Gridpoints',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'zreal',ier)
               CALL close_hdf5(fid,ier)
               IF (ier /= 0) CALL handle_err(HDF5_CLOSE_ERR,'torlines_'//TRIM(id_string)//'.h5',ier)
            END IF
         CASE('FIELD')
            IF (myworkid == master) THEN
               CALL open_hdf5('torlines_'//TRIM(id_string)//'.h5',fid,ier,LCREATE=.false.)
               IF (ier /= 0) CALL handle_err(HDF5_OPEN_ERR,'torlines_'//TRIM(id_string)//'.h5',ier)
               CALL write_var_hdf5(fid,'bsreal',nrho,nu,nv,ier,DBLVAR=bsreal,ATT='B^S Real',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'bsreal',ier)
               CALL write_var_hdf5(fid,'bureal',nrho,nu,nv,ier,DBLVAR=bureal,ATT='B^U Real',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'bureal',ier)
               CALL write_var_hdf5(fid,'bvreal',nrho,nu,nv,ier,DBLVAR=bvreal,ATT='B^V Real',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'bvreal',ier)
               CALL write_var_hdf5(fid,'breal',nrho,nu,nv,ier,DBLVAR=breal,ATT='|B| Real',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'breal',ier)
               CALL close_hdf5(fid,ier)
               IF (ier /= 0) CALL handle_err(HDF5_CLOSE_ERR,'torlines_'//TRIM(id_string)//'.h5',ier)
            END IF
         CASE('FIELDLINES')
            mystart = LBOUND(R_lines,1)
            myend   = UBOUND(R_lines,1)
            CALL MPI_ALLREDUCE(myend,nlines,1,MPI_INTEGER,MPI_MAX,MPI_COMM_FIELDLINES,ierr_mpi)
            CALL torlines_write2d_parhdf5(1, nlines, 0, nsteps, mystart, myend,   'R_lines', DBLVAR=R_lines)
            CALL torlines_write2d_parhdf5(1, nlines, 0, nsteps, mystart, myend, 'PHI_lines', DBLVAR=PHI_lines)
            CALL torlines_write2d_parhdf5(1, nlines, 0, nsteps, mystart, myend,   'Z_lines', DBLVAR=Z_lines)
            CALL torlines_write2d_parhdf5(1, nlines, 0, nsteps, mystart, myend,   'B_lines', DBLVAR=B_lines)
            CALL torlines_write2d_parhdf5(1, nlines, 0, nsteps, mystart, myend,   'U_lines', DBLVAR=U_lines)
            IF (myworkid == master) THEN
               CALL open_hdf5('torlines_'//TRIM(id_string)//'.h5',fid,ier,LCREATE=.false.)
               IF (ier /= 0) CALL handle_err(HDF5_OPEN_ERR,'torlines_'//TRIM(id_string)//'.h5',ier)
               CALL write_scalar_hdf5(fid,'nlines',ier,INTVAR=nlines,ATT='Number of Fieldlines',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'nlines',ier)
               CALL write_scalar_hdf5(fid,'nsteps',ier,INTVAR=nsteps+1,ATT='Number of Steps Along Fieldline',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'nsteps',ier)
               CALL write_scalar_hdf5(fid,'npoinc',ier,INTVAR=npoinc,ATT='Number of steps per field period',ATT_NAME='description')
               IF (ier /= 0) CALL handle_err(HDF5_WRITE_ERR,'npoinc',ier)
               CALL close_hdf5(fid,ier)
               IF (ier /= 0) CALL handle_err(HDF5_CLOSE_ERR,'torlines_'//TRIM(id_string)//'.h5',ier)
            END IF
      END SELECT
!DEC$ IF DEFINED (MPI_OPT)
      ! Make sure we wait till we're done
      CALL MPI_BARRIER(MPI_COMM_FIELDLINES,ierr_mpi)
      IF (ierr_mpi /=0) CALL handle_err(MPI_BARRIER_ERR,'torlines_write',ierr_mpi)
!DEC$ ENDIF

!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE torlines_write


Subroutine luboei(nsav)
  Implicit Double Precision (D)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Save /lujets/
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Dimension dps(4), kfbe(9), nbe(0:9), bei(100)
  Data kfbe/211, -211, 111, 321, -321, 130, 310, 221, 331/
  If ((mstj(51)/=1 .And. mstj(51)/=2) .Or. n-nsav<=1) Return
  Do j = 1, 4
    dps(j) = 0.D0
  End Do
  Do i = 1, n
    If (k(i,1)<=0 .Or. k(i,1)>10) Goto 120
    Do j = 1, 4
      dps(j) = dps(j) + dble(p(i,j))
    End Do
  120 End Do
  Call ludbrb(0, 0, 0., 0., -dps(1)/dps(4), -dps(2)/dps(4), -dps(3)/dps(4))
  pecm = 0.
  Do i = 1, n
    If (k(i,1)>=1 .And. k(i,1)<=10) pecm = pecm + p(i, 4)
  End Do
  nbe(0) = n + mstu(3)
  Do ibe = 1, min(9, mstj(51))
    nbe(ibe) = nbe(ibe-1)
    Do i = nsav + 1, n
      If (k(i,2)/=kfbe(ibe)) Goto 150
      If (k(i,1)<=0 .Or. k(i,1)>10) Goto 150
      If (nbe(ibe)>=mstu(4)-mstu(32)-5) Then
        Call luerrm(11, '(LUBOEI:) no more memory left in LUJETS')
        Return
      End If
      nbe(ibe) = nbe(ibe) + 1
      k(nbe(ibe), 1) = i
      Do j = 1, 3
        p(nbe(ibe), j) = 0.
      End Do
    150 End Do
  End Do
  Do ibe = 1, min(9, mstj(51))
    If (ibe/=1 .And. ibe/=4 .And. ibe<=7) Goto 180
    If (ibe==1 .And. max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))<=1) Goto 180
    If (ibe==4 .And. max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),nbe(7)-nbe(6))<=1) Goto 180
    If (ibe>=8 .And. nbe(ibe)-nbe(ibe-1)<=1) Goto 180
    If (ibe==1) pmhq = 2.*ulmass(211)
    If (ibe==4) pmhq = 2.*ulmass(321)
    If (ibe==8) pmhq = 2.*ulmass(221)
    If (ibe==9) pmhq = 2.*ulmass(331)
    qdel = 0.1*min(pmhq, parj(93))
    If (mstj(51)==1) Then
      nbin = min(100, nint(9.*parj(93)/qdel))
      beex = exp(0.5*qdel/parj(93))
      bert = exp(-qdel/parj(93))
    Else
      nbin = min(100, nint(3.*parj(93)/qdel))
    End If
    Do ibin = 1, nbin
      qbin = qdel*(ibin-0.5)
      bei(ibin) = qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)
      If (mstj(51)==1) Then
        beex = beex*bert
        bei(ibin) = bei(ibin)*beex
      Else
        bei(ibin) = bei(ibin)*exp(-(qbin/parj(93))**2)
      End If
      If (ibin>=2) bei(ibin) = bei(ibin) + bei(ibin-1)
    End Do
    180 Do i1m = nbe(ibe-1) + 1, nbe(ibe) - 1
      i1 = k(i1m, 1)
      Do i2m = i1m + 1, nbe(ibe)
        i2 = k(i2m, 1)
        q2old = max(0., (p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)
        qold = sqrt(q2old)
        If (qold<0.5*qdel) Then
          qmov = qold/3.
        Else If (qold<(nbin-0.1)*qdel) Then
          rbin = qold/qdel
          ibin = int(rbin)
          rinp = (rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
          qmov = (bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*sqrt(q2old+pmhq**2)/q2old
        Else
          qmov = bei(nbin)*sqrt(q2old+pmhq**2)/q2old
        End If
        q2new = q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)
        hc1 = (p(i1,4)+p(i2,4))**2 - (q2old-q2new)
        hc2 = (q2old-q2new)*(p(i1,4)-p(i2,4))**2
        ha = 0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))
        Do j = 1, 3
          pd = ha*(p(i2,j)-p(i1,j))
          p(i1m, j) = p(i1m, j) + pd
          p(i2m, j) = p(i2m, j) - pd
        End Do
      End Do
    End Do
  End Do
  Do im = nbe(0) + 1, nbe(min(9,mstj(51)))
    i = k(im, 1)
    Do j = 1, 3
      p(i, j) = p(i, j) + p(im, j)
    End Do
    p(i, 4) = sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
  End Do
  pes = 0.
  pqs = 0.
  Do i = 1, n
    If (k(i,1)<=0 .Or. k(i,1)>10) Goto 240
    pes = pes + p(i, 4)
    pqs = pqs + p(i, 5)**2/p(i, 4)
  240 End Do
  fac = (pecm-pqs)/(pes-pqs)
  Do i = 1, n
    If (k(i,1)<=0 .Or. k(i,1)>10) Goto 260
    Do j = 1, 3
      p(i, j) = fac*p(i, j)
    End Do
    p(i, 4) = sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
  260 End Do
  Call ludbrb(0, 0, 0., 0., dps(1)/dps(4), dps(2)/dps(4), dps(3)/dps(4))
  Return
End Subroutine luboei