      module parameters_C
!
! This module holds all the parameters for the elements.  It is filled
! from the reference parameter sets
!
      USE vast_kind_param, ONLY:  double
!...Created by Pacific-Sierra Research 77to90  4.4G  11:04:16  03/09/06
    logical, dimension(107) :: dorbs
    real(double), dimension(107) :: alp
    real(double), dimension(107,4) :: guess1, guess2, guess3
    real(double), dimension(6,107) :: ddp
    real(double), dimension(9,107) :: po
    real(double), dimension(107) :: betas, betap, betad
    real(double), dimension(107) :: uss, upp, udd
    real(double), dimension(107) :: gpp, gp2, hsp, gss, gsp, hpp
    real(double), dimension(107) :: am, ad, aq, dd, qq
    real(double), dimension(107) :: zs, zp, zd, zsn, zpn, zdn
    real(double), dimension(107) :: eisol, eheat
    real(double), dimension(107) :: ams
    real(double), dimension (107) :: tore, polvol, pocord, f0dd, f2dd, f4dd, &
    f0sd, g2sd, f0pd, f2pd, g1pd, g3pd
    integer, dimension (107,3) :: npq
    integer, dimension (107) :: iod, iop, ios
    integer, dimension (107) :: natsp, natorb, natspd
    logical, dimension (107) :: main_group

    save
!              H           Initial "s" Orbital Occupancies                     He
!              Li Be                                            B  C  N  O  F  Ne
!              Na Mg                                            Al Si P  S  Cl Ar
!              K  Ca Sc            Ti V  Cr Mn Fe Co Ni Cu Zn   Ga Ge As Se Br Kr
!              Rb Sr Y             Zr Nb Mo Tc Ru Rh Pd Ag Cd   In Sn Sb Te I  Xe
!              Cs Ba La Ce-Lu      Hf Ta W  Re Os Ir Pt Au Hg   Tl Pb Bi Po At Rn
!              Fr Ra Ac Th Pa U    Np Pu Am Cm Bk Cf            Cb ++ +  -- -  Tv
!                                      "s" shell
    data ios &
        &/ 1,                                                                2, &!    2
        &  1, 2,                                              2, 2, 2, 2, 2, 0, &!   10
        &  1, 2,                                              2, 2, 2, 2, 2, 0, &!   18
        &  1, 2, 2,              2, 2, 1, 2, 2, 2, 2, 1, 2,   2, 2, 2, 2, 2, 0, &!   36
        &  1, 2, 2,              2, 1, 1, 2, 1, 1, 0, 1, 2,   2, 2, 2, 2, 2, 0, &!   54
        &  1, 2, 2, 5*0,3*2,6*2, 2, 2, 1, 2, 2, 2, 1, 1, 2,   2, 2, 2, 2, 2, 0, &!   86
        &  1, 1, 2, 4, 2, 2,     2, 2, 2, 2, 2, 2, 0, 3,-3,   1, 2, 1,-2,-1, 0 /
!                                  /
!
!              H           Initial "p" Orbital Occupancies                   He
!              Li Be                                          B  C  N  O  F  Ne
!              Na Mg                                          Al Si P  S  Cl Ar
!              K  Ca Sc          Ti V  Cr Mn Fe Co Ni Cu Zn   Ga Ge As Se Br Kr
!              Rb Sr Y           Zr Nb Mo Tc Ru Rh Pd Ag Cd   In Sn Sb Te I  Xe
!              Cs Ba La Ce-Lu    Hf Ta W  Re Os Ir Pt Au Hg   Tl Pb Bi Po At Rn
!              Fr Ra Ac Th Pa U  Np Pu Am Cm Bk Cf (The rest are reserved for MOPAC)
!                                      "p" shell
    data iop / 0 ,                                                           0, &!    2
            &  0, 0,                                          1, 2, 3, 4, 5, 6, &!   10
            &  0, 0,                                          1, 2, 3, 4, 5, 6, &!   18
            &  0, 0, 0,          0, 0, 0, 0, 0, 0, 0, 0, 0,   1, 2, 3, 4, 5, 6, &!   36
            &  0, 0, 0,          0, 0, 0, 0, 0, 0, 0, 0, 0,   1, 2, 3, 4, 5, 6, &!   54
            &  0, 0, 0,  14*0,   0, 0, 0, 0, 0, 0, 0, 0, 0,   1, 2, 3, 4, 5, 6, &!   86
            &  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9*0                        /
!
!              H           Initial "d" Orbital Occupancies                   He
!              Li Be                                          B  C  N  O  F  Ne
!              Na Mg                                          Al Si P  S  Cl Ar
!              K  Ca Sc          Ti V  Cr Mn Fe Co Ni Cu Zn   Ga Ge As Se Br Kr
!              Rb Sr Y           Zr Nb Mo Tc Ru Rh Pd Ag Cd   In Sn Sb Te I  Xe
!              Cs Ba La Ce-Lu    Hf Ta W  Re Os Ir Pt Au Hg   Tl Pb Bi Po At Rn
!              Fr Ra Ac Th Pa U  Np Pu Am Cm Bk Cf (The rest are reserved for MOPAC)
!                                      "d" shell
    data iod / 0,                                                           0, &!    2
             & 0, 0,                                         0, 0, 0, 0, 0, 0, &!   10
             & 0, 0,                                         0, 0, 0, 0, 0, 0, &!   18
             & 0, 0, 1,          2, 3, 5, 5, 6, 7, 8, 10, 0, 0, 0, 0, 0, 0, 0, &!   36
             & 0, 0, 1,          2, 4, 5, 5, 7, 8,10, 10, 0, 0, 0, 0, 0, 0, 0, &!   54
             & 0, 0, 1,13*0,  1, 2, 3, 5, 5, 6, 7, 9, 10, 0, 0, 0, 0, 0, 0, 0, &!   86
             & 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9*0                     /
!
!                     Principal Quantum Numbers for all shells.
!
!              H                 "s"  shell                                  He
!              Li Be                                          B  C  N  O  F  Ne
!              Na Mg                                          Al Si P  S  Cl Ar
!              K  Ca Sc          Ti V  Cr Mn Fe Co Ni Cu Zn   Ga Ge As Se Br Kr
!              Rb Sr Y           Zr Nb Mo Tc Ru Rh Pd Ag Cd   In Sn Sb Te I  Xe
!              Cs Ba La Ce-Lu    Hf Ta W  Re Os Ir Pt Au Hg   Tl Pb Bi Po At Rn
!              Fr Ra Ac Th-Lr    ?? ?? ?? ??
!
data npq(1:107,1) / &
             & 1,                                                             1, &!  2
             & 2, 2,                                           2, 2, 2, 2, 2, 3, &! 10
             & 3, 3,                                           3, 3, 3, 3, 3, 4, &! 18
             & 4, 4,             4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, &! 36
             & 5, 5,             5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, &! 54
             & 6, 6, 14 * 6,     6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, &! 86
             & 15 * 0, 3, 5 * 0 /
!
!              H                "p"  shell                                   He
!              Li Be                                          B  C  N  O  F  Ne
!              Na Mg                                          Al Si P  S  Cl Ar
!              K  Ca Sc          Ti V  Cr Mn Fe Co Ni Cu Zn   Ga Ge As Se Br Kr
!              Rb Sr Y           Zr Nb Mo Tc Ru Rh Pd Ag Cd   In Sn Sb Te I  Xe
!              Cs Ba La Ce-Lu    Hf Ta W  Re Os Ir Pt Au Hg   Tl Pb Bi Po At Rn
!              Fr Ra Ac Th-Lr    ?? ?? ?? ??
!
data npq(1:107,2) / &
             & 1,                                                             2, &!  2
             & 2, 2,                                           2, 2, 2, 2, 2, 2, &! 10
             & 3, 3,                                           3, 3, 3, 3, 3, 3, &! 18
             & 4, 4,             4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, &! 36
             & 5, 5,             5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, &! 54
             & 6, 6, 14 * 6,     6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, &! 86
             & 21 * 0 /
!
!              H                 "d"  shell                                  He
!              Li Be                                          B  C  N  O  F  Ne
!              Na Mg                                          Al Si P  S  Cl Ar
!              K  Ca Sc          Ti V  Cr Mn Fe Co Ni Cu Zn   Ga Ge As Se Br Kr
!              Rb Sr Y           Zr Nb Mo Tc Ru Rh Pd Ag Cd   In Sn Sb Te I  Xe
!              Cs Ba La Ce-Lu    Hf Ta W  Re Os Ir Pt Au Hg   Tl Pb Bi Po At Rn
!              Fr Ra Ac Th-Lr    ?? ?? ?? ??
!
data npq(1:107,3) / &
             & 0,                                                             3, &!  2
             & 0, 0,                                           0, 0, 0, 0, 0, 3, &! 10
             & 3, 3,                                           3, 3, 3, 3, 3, 4, &! 18
             & 3, 3,             3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 5, &! 36
             & 4, 4,             4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, &! 54
             & 5, 5, 14 * 5,     5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, &! 86
             & 21 * 0 /
!
!   NATSP IS THE NUMBER OF ATOMIC ORBITALS PER ATOM
!
!                               Group
!             1 2  Transition Metals    3 4 5 6 7         8
!
!    H                                                  He
!    Li Be                               B  C  N  O  F  Ne
!    Na Mg                               Al Si P  S  Cl Ar
!    K  Ca Sc Ti V  Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr
!    Rb Sr Y  Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I  Xe
!    Cs Ba
!             La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb
!          Lu Hf Ta W  Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn
!    Fr Ra
!          Ac Th Pa U  Np Pu Am Cm Bk Cf
!    XX ?? ?? Cb
!
  data natsp / &
   & 1,                                                 4, & ! H  - He
   & 4, 4,                               4, 4, 4, 4, 4, 4, & ! Li - Ne
   & 0, 4,                               4, 4, 4, 4, 4, 4, & ! Na - Ar
   & 0, 4, 9, 9, 9, 9, 9, 9, 9, 9, 9, 4, 4, 4, 4, 4, 4, 4, & ! K  - Kr
   & 0, 4, 9, 9, 9, 9, 9, 9, 9, 9, 9, 4, 4, 4, 4, 4, 4, 4, & ! Rb - Xe
   & 0, 4,                                                 & ! Cs - Ba
   &          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,    & ! The Lanthanides
   &       0, 9, 9, 9, 9, 9, 9, 9, 9, 4, 4, 4, 4, 4, 4, 4, & ! Lu - Rn
   & 0, 4,                                                 & ! Fr - Ra
   &       4, 0, 4, 4, 4, 4, 4, 4, 4, 4,                   & ! The Actinides
   & 0, 0, 0, 1, 0,                                        & ! XX, ??, ??, Cb, ++
   & 0, 0, 0, 0                                            / ! +,  --,  -, Tv
!
!     LIST OF ELEMENTS WITH MNDO/d PARAMETERS.
!
!   NATSPD IS THE NUMBER OF ATOMIC ORBITALS PER ATOM FOR MNDO-D.
!
!                               Group
!                 1 2  Transition Metals    3 4 5 6 7         8
       data natspd / &
     &            1,                                          0,        &
     &            4,4,                      4,4,4,4,4,        0,        &
     &            4,4,                      9,9,9,9,9,        0,        &
     &            4,4, 9,9,9,9,9,9,9,9,9,4, 9,9,9,9,9,        0,        &
     &            4,4, 9,9,9,9,9,9,9,9,9,4, 9,9,9,9,9,        0,        &
     &            0,0,                                                  &
     &              0,0,0,0,0,0,0,0,0,0,0,0,0,0,                        &
     &                 9,9,9,9,9,9,9,9,9,4, 0,0,0,0,0,        0,        &
     &            0,0,                                                  &
     &              0,0,0,0,0,0,0,0,0,0,0,0,0,0,                        &
     &                                      0,0,0,0,0/
!
!  Main_group is .true. if the Gss, Gpp, etc., are independent of zsn, zpn, and zdn,
!  .false. otherwise.
!
!  For main-group elements, the Gss value is important, for the transition metals,
!  Gss is less important.
!
    data main_group /&
   &  2*.true.,                              & ! H  - He
   &  8*.true.,                              & ! Li - Ne
   &  8*.true.,                              & ! Na - Ar
   &  2*.true., 9*.false., 7*.true.,         & ! K  - Kr
   &  2*.true., 9*.false., 7*.true.,         & ! Rb - Xe
   &  2*.true.,23*.false., 7*.true.,         & ! Cs - Rn
   & 21*.true.                               / ! Fr - Tv
   !
!     ENTHALPIES OF FORMATION OF GASEOUS ATOMS ARE TAKEN FROM \ANNUAL
!     REPORTS,1974,71B,P 117\  THERE ARE SOME SIGNIFICANT DIFFERENCES
!     BETWEEN THE VALUES REPORTED THERE AND THE VALUES PREVIOUSLY IN
!     THE BLOCK DATA OF THIS PROGRAM.  ONLY THE THIRD  ROW ELEMENTS
!     HAVE BEEN UPDATED.
!
! ALL THE OTHER ELEMENTS ARE TAKEN FROM CRC HANDBOOK 1981-1982
    data eheat(1) / 52.102d0 /
    data eheat(2) / 0.000d0 /
    data eheat(3) / 38.410d0 /
    data eheat(4) / 76.960d0 /
    data eheat(5) / 135.700d0 /
    data eheat(6) / 170.890d0 /
    data eheat(7) / 113.000d0 /
    data eheat(8) / 59.559d0 /
    data eheat(9) / 18.890d0 /
    data eheat(10) / 0.000d0 /
    data eheat(11) / 25.650d0 /
    data eheat(12) / 35.000d0 /
    data eheat(13) / 79.490d0 /
    data eheat(14) / 108.390d0 /
    data eheat(15) / 75.570d0 /
    data eheat(16) / 66.400d0 /
    data eheat(17) / 28.990d0 /
    data eheat(18) / 0.000d0 /
    data eheat(19) / 21.420d0 /
    data eheat(20) / 42.600d0 /
    data eheat(21) / 90.300d0 /
    data eheat(22) / 112.300d0 /
    data eheat(23) / 122.900d0 /
    data eheat(24) / 95.000d0 /
    data eheat(25) / 67.700d0 /
    data eheat(26) / 99.300d0 /
    data eheat(27) / 102.400d0 /
    data eheat(28) / 102.800d0 /
    data eheat(29) / 80.700d0 /
    data eheat(30) / 31.170d0 /
    data eheat(31) / 65.400d0 /
    data eheat(32) / 89.500d0 /
    data eheat(33) / 72.300d0 /
    data eheat(34) / 54.300d0 /
    data eheat(35) / 26.740d0 /
    data eheat(36) / 0.000d0 /
    data eheat(37) / 19.600d0 /
    data eheat(38) / 39.100d0 /
    data eheat(39) / 101.500d0 /
    data eheat(40) / 145.500d0 /
    data eheat(41) / 172.400d0 /
    data eheat(42) / 157.300d0 /
    data eheat(43) / 162.000d0 /
    data eheat(44) / 155.500d0 /
    data eheat(45) / 133.000d0 /
    data eheat(46) / 90.000d0 /
    data eheat(47) / 68.100d0 /
    data eheat(48) / 26.720d0 /
    data eheat(49) / 58.000d0 /
    data eheat(50) / 72.200d0 /
    data eheat(51) / 63.200d0 /
    data eheat(52) / 47.000d0 /
    data eheat(53) / 25.517d0 /
    data eheat(54) / 0.000d0 /
    data eheat(55) / 18.700d0 /
    data eheat(56) / 42.500d0 /
    data eheat(57) / 928.9D0/   !  Represents La(+++)
    data eheat(58) / 944.7D0 /  !  Represents Ce(+++)
    data eheat(59) / 952.9D0 /  !  Represents Pr(+++)
    data eheat(60) / 962.8D0 /  !  Represents Nd(+++)
    data eheat(61) / 976.9D0 /  !  Represents Pm(+++)
    data eheat(62) / 974.4d0 /  !  Represents Sm(+++)
    data eheat(63) / 1006.6d0/  !  Represents Eu(+++)
    data eheat(64) / 991.37d0/  !  Represents Gd(+++)
    data eheat(65) / 999.0d0/   !  Represents Tb(+++)
    data eheat(66) / 1001.3d0 / !  Represents Dy(+++)
    data eheat(67) / 1009.6d0 / !  Represents Ho(+++)
    data eheat(68) / 1016.15d0 /!  Represents Er(+++)
    data eheat(69) / 1022.06d0/ !  Represents Tm(+++)
    data eheat(70) / 1039.03d0/ !  Represents Ho(+++)
    data eheat(71) / 1031.2d0 / !  Represents Lu(+++)
    data eheat(72) / 148.000d0 /
    data eheat(73) / 186.900d0 /
    data eheat(74) / 203.100d0 /
    data eheat(75) / 185.000d0 /
    data eheat(76) / 188.000d0 /
    data eheat(77) / 160.000d0 /
    data eheat(78) / 135.200d0 /
    data eheat(79) / 88.000d0 /
    data eheat(80) / 14.690d0 /
    data eheat(81) / 43.550d0 /
    data eheat(82) / 46.620d0 /
    data eheat(83) / 50.100d0 /
    data eheat(86) / 0.000d0 /
    data eheat(90) / 1674.64d0/
    data eheat(102) / 207.0d0 /
    data eheat(103) / 0.0d0 /
    data eheat(104) / 0.0d0 /
    data eheat(105) / 0.0d0 /
    data eheat(106) / 0.0d0 /
    data eheat(107) / 0.0d0 /
    data eisol / 107 * 0.0d0 /
    data ams / 1.00790d0, 4.00260d0, 6.94000d0, 9.01218d0, 10.81000d0, &
   & 12.01100d0, 14.00670d0, 15.99940d0, 18.99840d0, 20.17900d0, 22.98977d0, &
   & 24.30500d0, 26.98154d0, 28.08550d0, 30.97376d0, 32.06000d0, 35.45300d0, &
   & 39.94800d0, 39.09830d0, 40.08000d0, 44.95590d0, 47.90000d0, 50.94150d0, &
   & 51.99600d0, 54.93800d0, 55.84700d0, 58.93320d0, 58.71000d0, 63.54600d0, &
   & 65.38000d0, 69.73500d0, 72.59000d0, 74.92160d0, 78.96000d0, 79.90400d0, &
   & 83.80000d0, 85.46780d0, 87.62000d0, 88.90590d0, 91.22000d0, 92.90640d0, &
   & 95.94000d0, 98.90620d0, 101.0700d0, 102.9055d0, 106.4000d0, 107.8680d0, &
   & 112.4100d0, 114.8200d0, 118.6900d0, 121.7500d0, 127.6000d0, 126.9045d0, &
   & 131.3000d0, 132.9054d0, 137.3300d0, 138.9060d0, 140.1160d0, 140.9077d0, &
   & 144.2400d0, 145.0000d0, 150.3600d0, 151.9640d0, 157.2500d0, 158.9253d0, &
   & 162.5000d0, 164.9303d0, 167.2600d0, 168.9342d0, 173.0400d0, 174.9670d0, &
   & 178.4900d0, 180.9479d0, &
   & 183.8500d0, 186.2070d0, 190.2000d0, 192.2200d0, 195.0900d0, 196.9665d0, &
   & 200.5900d0, 204.3700d0, 207.2000d0, 208.9804d0, 209.0000d0, 210.0000d0, &
   & 222.0000d0, 223.0000d0, 226.0000d0, 227.0000d0, 232.0381d0, 231.0359d0, &
   & 238.0289d0, 9 * 0.000d0, 1.0079d0, &
   & 5 * 0.000d0 /
      end module parameters_C


!/ ------------------------------------------------------------------- /
      MODULE W3IOPOMD
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         29-May-2009 |
!/                  +-----------------------------------+
!/
!/    25-Jan-2001 : Origination.                        ( version 2.00 )
!/    24-Jan-2001 : Flat grid version.                  ( version 2.06 )
!/    11-Jun-2001 : Clean-up.                           ( version 2.11 )
!/    10-Nov-2004 : Multiple grid version.              ( version 3.06 )
!/    27-Jun-2006 : Adding file name preamble.          ( version 3.09 )
!/    25-Jul-2006 : Adding grid ID per point.           ( version 3.10 )
!/    01-May-2007 : Move O7a output from W3INIT.        ( version 3.11 )
!/    29-May-2009 : Preparing distribution version.     ( version 3.14 )
!/
!/    Copyright 2009 National Weather Service (NWS),
!/       National Oceanic and Atmospheric Administration.  All rights
!/       reserved.  WAVEWATCH III is a trademark of the NWS.
!/       No unauthorized use without permission.
!/
!  1. Purpose :
!
!     Process point output.
!
!  2. Variables and types :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      VEROPT    C*10  Private  Point output file version number.
!      IDSTR     C*32  Private  Point output file ID string.
!     ----------------------------------------------------------------
!
!  3. Subroutines and functions :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      W3IOPP    Subr. Public   Preprocessing of point output req.
!      W3IOPE    Subr. Public   Extract point data from grid.
!      W3IOPO    Subr. Public   Point data IO.
!     ----------------------------------------------------------------
!
!  4. Subroutines and functions used :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3SETO    Subr. W3ODATMD Data structure management.
!      W3SETG    Subr. W3GDATMD Data structure management.
!      W3SETW    Subr. W3WDATMD Data structure management.
!      W3DMO2    Subr. W3ODATMD Data structure management.
!      STRACE    Subr. W3SERVMD Subroutine tracing.
!      EXTCDE    Subr. W3SERVMD Program abort with exit code.
!      MPI_STARTALL, MPIWAITALL
!                Subr.          MPI persistent communication routines.
!     ----------------------------------------------------------------
!
!  5. Remarks :
!
!     - Allocation of allocatable arrays takes place at different
!       places throughout the code, in W3IOPP on write, and in
!       W3IOPO on read.
!
!  6. Switches :
!
!       !/LLG   Spherical grid.
!       !/XYG   Carthesian grid.
!
!       !/S     Enable subroutine tracing.
!       !/T     Enable test output.
!
!       !/SHRD  Switch for shared / distributed memory architecture.
!       !/DIST  Id.
!       !/MPI   MPI message passing.
!
!       !/O7a   Diagnostic output for output points.
!
!  7. Source code :
!
!/ ------------------------------------------------------------------- /
      PUBLIC
!/
!/ Private parameter statements (ID strings)
!/
      CHARACTER(LEN=10), PARAMETER, PRIVATE :: VEROPT = 'III  2.01 '
      CHARACTER(LEN=31), PARAMETER, PRIVATE ::                        &
                           IDSTR = 'WAVEWATCH III POINT OUTPUT FILE'
!/
      CONTAINS
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD )
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         01-May-2007 |
!/                  +-----------------------------------+
!/
!/    14-Jan-1999 : Distributed FORTRAN 77 version.     ( version 1.18 )
!/    30-Dec-1999 : Upgrade to FORTRAN 90               ( version 2.00 )
!/                  Major changes to logistics.
!/    24-Jan-2001 : Flat grid version.                  ( version 2.06 )
!/    09-Nov-2004 : Multiple grid version.              ( version 3.06 )
!/    25-Jul-2006 : Adding grid ID per point.           ( version 3.10 )
!/    01-May-2007 : Move O7a output from W3INIT.        ( version 3.11 )
!/
!  1. Purpose :
!
!     Preprocessing of point output.
!
!  2. Method :
!
!     Check location of points in grid and calculate interpolation
!     factors.
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       NPT     Int.   I   Number of output points in input.
!       XPT     R.A.  I/O  X (longitude) coordinates of output points.
!       YPT     R.A.  I/O  Id. Y.
!       PNAMES  C*10   I   Names of output points.
!       IMOD    Int.   I   Grid ID number.
!     ----------------------------------------------------------------
!
!     Local data
!     ----------------------------------------------------------------
!       ACC     Real  "Accuracy" factor to determine if output point
!                     is grid point.
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!     See module documentation.
!
!  5. Called by :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3INIT    Subr. W3INITMD Wave model initialization routine.
!     ----------------------------------------------------------------
!
!  6. Error messages :
!
!     - Warnings for points out of the grid or on land.
!
!  7. Remarks :
!
!     - The output points are obtained by bi-linear interpolation from
!       the spectra at the grid points. Given the possibility of ice
!       coverage, the actual interpolation factors can only be
!       determined at the actual output time. Hence only the basic
!       bilinear interpolation factors are stored.
!
!  8. Structure :
!
!     -------------------------------------------
!      Determine grid range
!      do for all defined points
!      -----------------------------------------
!        Check if point within grid
!        Calculate interpolation data
!        Check if point not on land
!        Store interpolation data
!     -------------------------------------------
!
!  9. Switches :
!
!       !/LLG   Spherical grid.
!       !/XYG   Carthesian grid.
!
!       !/S     Enable subroutine tracing.
!       !/T     Test output.
!
!       !/O7a   Diagnostic output for output points.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      USE W3GDATMD, ONLY: NTH, NK, NSPEC, NX, NY, X0, Y0, SX, SY,     &
                          MAPSTA, MAPFS, GLOBAL, FILEXT, ZB, TRNX, TRNY
      USE W3ODATMD, ONLY: W3DMO2
      USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR, NAPOUT, SCREEN, &
                          NOPTS, PTLOC, PTNME, GRDID, IPTINT, PTIFAC
      USE W3SERVMD, ONLY: EXTCDE
!
      IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      INTEGER, INTENT(IN)          :: NPT, IMOD
      REAL, INTENT(INOUT)          :: XPT(NPT), YPT(NPT)
      CHARACTER(LEN=10),INTENT(IN) :: PNAMES(NPT)
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
      INTEGER                 :: IPT, IX1, IY1, IXS, IYS
      REAL                    :: XN, YN, RX, RY, RDX, RDY
      REAL, PARAMETER         :: ACC = 0.05
       REAL                   :: FACTOR = 1.
!
!/
!/ ------------------------------------------------------------------- /
!/
!
      CALL W3DMO2 ( IMOD, NDSE, NDST, NPT )
      GRDID  = FILEXT
!
      XN     = X0 + REAL(NX-1)*SX
      YN     = Y0 + REAL(NY-1)*SY
      NOPTS  = 0
!
! Loop over output points
!
      DO IPT=1, NPT
!
! Correct XPT if necessary
!
        IF ( XPT(IPT) .GT. XN+ACC*SX ) XPT(IPT) = XPT(IPT)       &
                           - 360.*REAL(1+INT((XPT(IPT)-XN)/360.))
        IF ( XPT(IPT) .LT. X0-ACC*SX ) XPT(IPT) = XPT(IPT)       &
                           + 360.*REAL(1+INT((X0-XPT(IPT))/360.))
!
!     Check if point within grid
!
        IF ( GLOBAL ) THEN
            IF (YPT(IPT) .LT. Y0 - ACC*SY .OR.                        &
                YPT(IPT) .GT. YN + ACC*SY ) THEN
                IF ( IAPROC .EQ. NAPERR )                             &
                    WRITE (NDSE,1000) XPT(IPT), YPT(IPT), PNAMES(IPT)
                CYCLE
              END IF
          ELSE
            IF (XPT(IPT) .LT. X0 - ACC*SX .OR.                        &
                XPT(IPT) .GT. XN + ACC*SX .OR.                        &
                YPT(IPT) .LT. Y0 - ACC*SY .OR.                        &
                YPT(IPT) .GT. YN + ACC*SY ) THEN
                IF ( IAPROC .EQ. NAPERR )                             &
                    WRITE (NDSE,1000) XPT(IPT), YPT(IPT), PNAMES(IPT)
                CYCLE
              END IF
          END IF
!
!     Calculate interpolation data
!
        RX     = ( XPT(IPT) - X0 ) / SX
        RY     = ( YPT(IPT) - Y0 ) / SY
        RDX    =  MOD ( RX , 1. )
        RDY    =  MOD ( RY , 1. )
        IF ( RDX.LT.0. ) RDX = RDX + 1.
        IF ( RDY.LT.0. ) RDY = RDY + 1.
!
        IX1    = 1 + INT(RX)
        IY1    = 1 + INT(RY)
        IXS    = 1
        IYS    = 1
!
        IF ( RDX .LE. ACC ) THEN
            IXS    = 0
            RDX    = 0.
          END IF
        IF ( RDX .GE. 1.-ACC ) THEN
            IXS    = 0
            IX1    = IX1 + 1
            RDX    = 0.
          END IF
        IF ( RDY .LE. ACC ) THEN
            IYS    = 0
            RDY    = 0.
          END IF
        IF ( RDY .GE. 1.-ACC ) THEN
            IYS    = 0
            IY1    = IY1 + 1
            RDY    = 0.
          END IF
!
!     Check if point not on land
!
        IF (MAPSTA(  IY1  ,  IX1  ).EQ.0 .AND.                        &
            MAPSTA(  IY1  ,IX1+IXS).EQ.0 .AND.                        &
            MAPSTA(IY1+IYS,  IX1  ).EQ.0 .AND.                        &
            MAPSTA(IY1+IYS,IX1+IXS).EQ.0) THEN
            IF ( IAPROC .EQ. NAPERR )                                 &
                    WRITE (NDSE,1001) XPT(IPT), YPT(IPT), PNAMES(IPT)
            CYCLE
          END IF
!
!     Store interpolation data
!
        NOPTS  = NOPTS + 1
!
        PTLOC (1,NOPTS) = XPT(IPT)
        PTLOC (2,NOPTS) = YPT(IPT)
!
        IF ( IX1.NE.NX .OR. GLOBAL ) THEN
            IPTINT(1,NOPTS) = IX1
            PTIFAC(1,NOPTS) = RDX
          ELSE
            IPTINT(1,NOPTS) = IX1 - 1
            PTIFAC(1,NOPTS) = 1.
          END IF
        IF ( IY1.NE.NY ) THEN
            IPTINT(2,NOPTS) = IY1
            PTIFAC(2,NOPTS) = RDY
          ELSE
            IPTINT(2,NOPTS) = IY1 - 1
            PTIFAC(2,NOPTS) = 1.
          END IF
!
        PTNME(NOPTS) = PNAMES(IPT)
!
        END DO
!
! Diagnostic output
!

!
      RETURN
!
! Formats
!
 1000 FORMAT (/' *** WAVEWATCH III WARNING :'/                   &
               '     OUTPUT POINT OUT OF GRID : ',2F10.3,2X,A/   &
               '     POINT SKIPPPED '/)
!
 1001 FORMAT (/' *** WAVEWATCH III WARNING :'/                   &
               '     OUTPUT POINT ON LAND : ',2F10.3,2X,A/       &
               '     POINT SKIPPPED '/)
!
!/
!/ End of W3IOPP ----------------------------------------------------- /
!/
      END SUBROUTINE W3IOPP
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3IOPE ( A )
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         09-Nov-2004 |
!/                  +-----------------------------------+
!/
!/    12-Jan-1999 : Distributed FORTRAN 77 version.     ( version 1.18 )
!/    25-Jan-2000 : Upgrade to FORTRAN 90               ( version 2.00 )
!/                  Major changes to logistics.
!/    11-Jun-2001 : Clean-up.                           ( version 2.11 )
!/    09-Nov-2004 : Multiple grid version.              ( version 3.06 )
!/
!  1. Purpose :
!
!     Extract point output data and store in output COMMONs. This
!     action is taken from an earlier version of W3IOPO so that the
!     point output postprocessor does not need the full sea-point
!     grid to be able to run.
!       Note that the output spectrum is F(f,theta). Interpolation
!     is performed for this spectrum.
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       A       R.A.   I   Action spectra on storage grid.
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!     See module documentation.
!
!  5. Called by :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3WAVE    Subr. W3WAVEMD Actual wave model routine.
!     ----------------------------------------------------------------
!
!  6. Error messages :
!
!       None.
!
!  7. Remarks :
!
!     - To allow for dynamic ice edges, interpolation factors are
!       calculated for every time step separately.
!     - Wind current and depth data are interpolated ignoring ice,
!       spectrum is interpolated removing ice points.
!     - Spectra are left in par list to allow for change of shape of
!       arrays.
!     - IMOD is not passed to this routine. Since it is used only
!       in W3WAVE, it is assumed that the pointer are set
!       appropriately outside this routine.
!
!  8. Structure :
!
!     See source code.
!
!  9. Switches :
!
!     !/SHRD  Switch for shared / distributed memory architecture.
!     !/DIST  Id.
!     !/MPI   Switch for message passing method.
!
!     !/S     Enable subroutine tracing.
!     !/T     Test output.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      USE W3CONSTANTS
      USE W3GDATMD, ONLY: NK, NTH, SIG, NX, NY, NSEA, NSEAL,          &
                          MAPSTA, MAPFS
      USE W3ADATMD, ONLY: CG, DW, UA, UD, AS, CX, CY, SP => SPPNT
      USE W3ODATMD, ONLY: NDST, NOPTS, IPTINT, PTIFAC, IL, IW, II,    &
                          DPO, WAO, WDO, ASO, CAO, CDO, SPCO
      USE W3ODATMD, ONLY: IRQPO2
      USE W3SERVMD, ONLY: EXTCDE
!
      IMPLICIT NONE
!
      INCLUDE "mpif.h"
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      REAL, INTENT(IN)        :: A(NTH,NK,0:NSEAL)
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
      INTEGER                 :: I, IX1, IY1, IX(4), IY(4), J, IS(4), &
                                 IM(4), IK, ITH, ISP
      INTEGER                 :: IOFF, IERR_MPI
      INTEGER                 :: STAT(MPI_STATUS_SIZE,4*NOPTS)
      REAL                    :: RDX, RDY, RD(4), RDS, RDI, FACRD,    &
                                 WNDX, WNDY, CURX, CURY, FAC1(NK),    &
                                 FAC2(NK), FAC3(NK), FAC4(NK)
!/
!/ ------------------------------------------------------------------- /
!/
!
      CX(0)  = 0.
      CY(0)  = 0.
!
! Loop over spectra -------------------------------------------------- *
!
      DO I=1, NOPTS
!
! Unpack interpolation data
!
        IX1    = IPTINT(1,I)
        IY1    = IPTINT(2,I)
        RDX    = PTIFAC(1,I)
        RDY    = PTIFAC(2,I)
!
        IX(1)  = IX1
        IX(2)  = 1 + MOD(IX1,NX)
        IX(3)  = IX1
        IX(4)  = IX(2)
!
        IY(1)  = IY1
        IY(2)  = IY1
        IY(3)  = IY1 + 1
        IY(4)  = IY1 + 1
!
! Interpolation factors assuming sea points only
!
        RD(1)  = (1.-RDX) * (1.-RDY)
        RD(2)  =   RDX    * (1.-RDY)
        RD(3)  = (1.-RDX) *   RDY
        RD(4)  =   RDX    *   RDY
!
! Correct for land and ice and get sea point counters
!
        IL(I)  = 0
        IW(I)  = 0
        II(I)  = 0
        RDS    = 0.
        RDI    = 0.
!
        DO J=1, 4
          IS(J)  = MAPFS (IY(J),IX(J))
          IM(J)  = MAPSTA(IY(J),IX(J))
          IF ( IM(J).GT.0 ) THEN
              IW(I)  = IW(I) + 1
              RDS    = RDS + RD(J)
            ELSE
              IF ( IM(J).LT.0 ) THEN
                  II(I)  = II(I) + 1
                  RDI    = RDI + RD(J)
                ELSE
                  IL(I)  = IL(I) + 1
                  RD(J)  = 0.
                END IF
            END IF
          END DO
!
! Depth, wind and current, ignore ice
!
        IF ( RDS+RDI .GT. 1.E-7 ) THEN
            FACRD  = 1. / (RDS+RDI)
            RD     = RD * FACRD
          END IF
!
! Interpolate depth wind and current
!
        DPO(I) = RD(1)*DW(IS(1)) + RD(2)*DW(IS(2)) +                  &
                 RD(3)*DW(IS(3)) + RD(4)*DW(IS(4))
!
        WNDX   = RD(1) * UA(IS(1)) * COS(UD(IS(1))) +                 &
                 RD(2) * UA(IS(2)) * COS(UD(IS(2))) +                 &
                 RD(3) * UA(IS(3)) * COS(UD(IS(3))) +                 &
                 RD(4) * UA(IS(4)) * COS(UD(IS(4)))
        WNDY   = RD(1) * UA(IS(1)) * SIN(UD(IS(1))) +                 &
                 RD(2) * UA(IS(2)) * SIN(UD(IS(2))) +                 &
                 RD(3) * UA(IS(3)) * SIN(UD(IS(3))) +                 &
                 RD(4) * UA(IS(4)) * SIN(UD(IS(4)))
!
        WAO(I) = SQRT ( WNDX**2 + WNDY**2 )
        IF ( WAO(I).GT.1.E-7 ) THEN
            WDO(I) = ATAN2(WNDY,WNDX)
          ELSE
            WDO(I) = 0.
          END IF
!
        ASO(I) = RD(1)*AS(IS(1)) + RD(2)*AS(IS(2)) +                  &
                 RD(3)*AS(IS(3)) + RD(4)*AS(IS(4))
!
        CURX   = RD(1)*CX(IS(1)) + RD(2)*CX(IS(2)) +                  &
                 RD(3)*CX(IS(3)) + RD(4)*CX(IS(4))
        CURY   = RD(1)*CY(IS(1)) + RD(2)*CY(IS(2)) +                  &
                 RD(3)*CY(IS(3)) + RD(4)*CY(IS(4))
!
        CAO(I) = SQRT ( CURX**2 + CURY**2 )
        IF ( CAO(I).GT.1.E-7 ) THEN
            CDO(I) = ATAN2(CURY,CURX)
          ELSE
            CDO(I) = 0.
          END IF
!
! Interp. weights for spectra, no ice points (spectra by def. zero)
!
        IF ( RDS .GT. 1.E-7 ) THEN
            FACRD  = (RDS+RDI) / RDS
            RD     = RD * FACRD
          END IF
!
! Extract spectra, shared memory version
!        (done in separate step for MPP compatibility)
!
! Extract spectra, distributed memory version(s)
!
        IOFF   = 1 + 4*(I-1)
        CALL MPI_STARTALL ( 4, IRQPO2(IOFF), IERR_MPI )
        CALL MPI_WAITALL  ( 4, IRQPO2(IOFF), STAT, IERR_MPI )
!
! Interpolate spectrum
!
        DO IK=1, NK
          FAC1(IK) = TPI * SIG(IK) / CG(IK,IS(1))
          FAC2(IK) = TPI * SIG(IK) / CG(IK,IS(2))
          FAC3(IK) = TPI * SIG(IK) / CG(IK,IS(3))
          FAC4(IK) = TPI * SIG(IK) / CG(IK,IS(4))
          END DO
!
        DO IK=1,NK
          DO ITH=1,NTH
            ISP    = ITH + (IK-1)*NTH
            SPCO(ISP,I) = RD(1) * SP(ITH,IK,1) * FAC1(IK)             &
                        + RD(2) * SP(ITH,IK,2) * FAC2(IK)             &
                        + RD(3) * SP(ITH,IK,3) * FAC3(IK)             &
                        + RD(4) * SP(ITH,IK,4) * FAC4(IK)
            END DO
          END DO
!
        END DO
!
      RETURN
!
! Formats
!
!/
!/ End of W3IOPE ----------------------------------------------------- /
!/
      END SUBROUTINE W3IOPE
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD )
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         25-Jul-2006 |
!/                  +-----------------------------------+
!/
!/    07-Jan-1999 : Distributed FORTRAN 77 version.     ( version 1.18 )
!/    30-Dec-1999 : Upgrade to FORTRAN 90               ( version 2.00 )
!/                  Major changes to logistics.
!/    10-Nov-2004 : Multiple grid version.              ( version 3.06 )
!/    27-Jun-2006 : Adding file name preamble.          ( version 3.09 )
!/    25-Jul-2006 : Adding grid ID per point.           ( version 3.10 )
!/
!  1. Purpose :
!
!     Read/write point output.
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       INXOUT  C*(*)  I   Test string for read/write, valid are:
!                          'READ' and 'WRITE'.
!       NDSOP   Int.   I   File unit number.
!       IOTST   Int.   O   Test indictor for reading.
!                           0 : Data read.
!                          -1 : Past end of file.
!       IMOD    I(O)   I   Model number for W3GDAT etc.
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!     See module documentation.
!
!  5. Called by :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3WAVE    Subr. W3WAVEMD Actual wave model routine.
!      WW3_OUTP  Prog.   N/A    Postprocessing for point output.
!      GX_OUTP   Prog.   N/A    Grads postprocessing for point output.
!     ----------------------------------------------------------------
!
!  6. Error messages :
!
!       Tests on INXOUT, file status and on array dimensions.
!
!  7. Remarks :
!
!     - The output file has the pre-defined name 'out_pnt.FILEXT'.
!     - In MPP version of model data is supposed to be gatherd at the
!       correct processor before the routine is called.
!     - No error output filtering needed.
!
!  8. Structure :
!
!     See source code.
!
!  9. Switches :
!
!     !/SHRD  Switch for shared / distributed memory architecture.
!     !/DIST  Id.
!
!     !/S     Enable subroutine tracing.
!     !/T     Test output.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      USE W3GDATMD, ONLY: W3SETG
      USE W3WDATMD, ONLY: W3SETW
      USE W3ODATMD, ONLY: W3SETO, W3DMO2
!/
      USE W3GDATMD, ONLY: NTH, NK, NSPEC, FILEXT
      USE W3WDATMD, ONLY: TIME
      USE W3ODATMD, ONLY: NDST, NDSE, IPASS => IPASS2, NOPTS, IPTINT, &
                          IL, IW, II, PTLOC, PTIFAC, DPO, WAO, WDO,   &
                          ASO, CAO, CDO, SPCO, PTNME, O2INIT, FNMPRE, &
                          GRDID
!/
      USE W3SERVMD, ONLY: EXTCDE
!
      IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      INTEGER, INTENT(IN)           :: NDSOP
      INTEGER, INTENT(OUT)          :: IOTST
      INTEGER, INTENT(IN), OPTIONAL :: IMOD
      CHARACTER, INTENT(IN)         :: INXOUT*(*)
!/
!/ ------------------------------------------------------------------- /
!/ local parameters
!/
      INTEGER                 :: IGRD, IERR, MK, MTH, I, J
      LOGICAL,SAVE            :: WRITE
      CHARACTER(LEN=31)       :: IDTST
      CHARACTER(LEN=10)       :: VERTST
!/
!/ ------------------------------------------------------------------- /
!/
      IPASS  = IPASS + 1
      IOTST  = 0
!
! test input parameters ---------------------------------------------- *
!
      IF ( PRESENT(IMOD) ) THEN
          IGRD   = IMOD
        ELSE
          IGRD   = 1
        END IF
!
      CALL W3SETO ( IGRD, NDSE, NDST )
      CALL W3SETG ( IGRD, NDSE, NDST )
      CALL W3SETW ( IGRD, NDSE, NDST )
!
      IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' ) THEN
          WRITE (NDSE,900) INXOUT
          CALL EXTCDE ( 1 )
        END IF
!
      IF ( IPASS.EQ.1 ) THEN
          WRITE  = INXOUT.EQ.'WRITE'
        ELSE
          IF ( WRITE .AND. INXOUT.EQ.'READ' ) THEN
              WRITE (NDSE,901) INXOUT
              CALL EXTCDE ( 2 )
            END IF
        END IF
!
! open file ---------------------------------------------------------- *
!
      IF ( IPASS.EQ.1 ) THEN
!
          I      = LEN_TRIM(FILEXT)
          J      = LEN_TRIM(FNMPRE)
!
          IF ( WRITE ) THEN
              OPEN (NDSOP,FILE=FNMPRE(:J)//'out_pnt.'//FILEXT(:I),    &
                    FORM='UNFORMATTED',ERR=800,IOSTAT=IERR)
            ELSE
              OPEN (NDSOP,FILE=FNMPRE(:J)//'out_pnt.'//FILEXT(:I),    &
                    FORM='UNFORMATTED',ERR=800,IOSTAT=IERR,STATUS='OLD')
            END IF
!
          REWIND ( NDSOP )
!
! test info ---------------------------------------------------------- *
! ( IPASS = 1 )
!
          IF ( WRITE ) THEN
              WRITE (NDSOP)                                           &
                IDSTR, VEROPT, NK, NTH, NOPTS
            ELSE
              READ (NDSOP,END=801,ERR=802,IOSTAT=IERR)                &
                IDTST, VERTST, MK, MTH, NOPTS
!
              IF ( IDTST .NE. IDSTR ) THEN
                  WRITE (NDSE,902) IDTST, IDSTR
                  CALL EXTCDE ( 10 )
                END IF
              IF ( VERTST .NE. VEROPT ) THEN
                  WRITE (NDSE,903) VERTST, VEROPT
                  CALL EXTCDE ( 11 )
                END IF
              IF (NK.NE.MK .OR. NTH.NE.MTH) THEN
                  WRITE (NDSE,904) MK, MTH, NK, NTH
                  CALL EXTCDE ( 12 )
                END IF
              IF ( .NOT. O2INIT )                                     &
                  CALL W3DMO2 ( IGRD, NDSE, NDST, NOPTS )
            END IF
!
! Point specific info ------------------------------------------------ *
! ( IPASS = 1 )
!
          IF ( WRITE ) THEN
              WRITE (NDSOP)                                           &
                    ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS)
           ELSE
              READ  (NDSOP,END=801,ERR=802,IOSTAT=IERR)               &
                    ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS)
            END IF
!
        END IF
!
! TIME --------------------------------------------------------------- *
!
      IF ( WRITE ) THEN
          WRITE (NDSOP)                            TIME
       ELSE
          READ (NDSOP,END=803,ERR=802,IOSTAT=IERR) TIME
        END IF
!
! Loop over spectra -------------------------------------------------- *
!
      DO I=1, NOPTS
!
        IF ( WRITE ) THEN
             WRITE (NDSOP)                                            &
                    IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I),      &
                    ASO(I), CAO(I), CDO(I), GRDID(I),                 &
                    (SPCO(J,I),J=1,NSPEC)
          ELSE
             READ (NDSOP,END=801,ERR=802,IOSTAT=IERR)                 &
                    IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I),      &
                    ASO(I), CAO(I), CDO(I), GRDID(I),                 &
                    (SPCO(J,I),J=1,NSPEC)
          END IF
!
        END DO
!
      RETURN
!
! Escape locations read errors
!
  800 CONTINUE
      WRITE (NDSE,1000) IERR
      CALL EXTCDE ( 20 )
!
  801 CONTINUE
      WRITE (NDSE,1001)
      CALL EXTCDE ( 21 )
!
  802 CONTINUE
      WRITE (NDSE,1002) IERR
      CALL EXTCDE ( 22 )
!
  803 CONTINUE
      IOTST  = -1
      RETURN
!
! Formats
!
  900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/                &
               '     ILEGAL INXOUT VALUE: ',A/)
  901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/                &
               '     MIXED READ/WRITE, LAST REQUEST: ',A/)
  902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/                &
               '     ILEGAL IDSTR, READ : ',A/                        &
               '                  CHECK : ',A/)
  903 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/                &
               '     ILEGAL VEROPT, READ : ',A/                       &
               '                   CHECK : ',A/)
  904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO :'/                &
               '     ERROR IN SPECTRA, MK, MTH : ',2I8/               &
               '              ARRAY DIMENSIONS : ',2I8/)
!
 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/               &
               '     ERROR IN OPENING FILE'/                          &
               '     IOSTAT =',I5/)
 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/               &
               '     PREMATURE END OF FILE'/)
 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOPO : '/               &
               '     ERROR IN READING FROM FILE'/                     &
               '     IOSTAT =',I5/)
!

!
!/
!/ End of W3IOPO ----------------------------------------------------- /
!/
      END SUBROUTINE W3IOPO
!/
!/ End of module W3IOPOMD -------------------------------------------- /
!/
      END MODULE W3IOPOMD


      subroutine transelec(npt,iyd,UTsec,glat,glong,stl,f107,
     .          ap,chi,Ne,Te,Tj,nx,Nh,No,No2,Nn2,Nn,Tn,indlim,jpreci0,
     .          kiappel,zlim,zlim_1,z,Heat,Ph,Po,Po2,Pn2,Pn,
     .          Ne_sup,courant_sup,Te_sup,Chaleur_sup)
c
c 	Ce programme est un driver.
c       This program is a driver.
c
c 	- Lit toutes les donnees necessaires a une execution.
c         Reads all the required data to an execution.
c
c		--> si kiappel = 1, ce sont les donnees contenue dans ELEC et NEUTRAL pour un run unique du programme.
c		    if kiappel = 1, the data are contained in ELEC and NEUTRAL for a single run of the program.
c
c 		--> si kiappel = 2, ce sont les donnees necessaires au transport fluide.
c		    if kiappel = 2, these are the necessary data transmission fluid
c
c 	- appelle le programme de degradation d'energie.
c	  program called Energy degradation.
c
c 	- appelle si necessaire celui de calcul de la photoionisation.
c         call if necessary the calculation photoionization
c 		--> si jpreci = 0, 2, 5 ou 6. if jpreci = 0, 2, 5 or 6.
c
c 	- appelle le code de transport
c	  called the transport code
c
c 	- eventuellement, interpolle sur les grilles du transfluide
c	  possibly interpolated on the fence transfluide
c
c       The necessary data for a code to another by the intermediary are non-formatted files.
c       This method is costly in time MAYBE, but very practical.
c	Each program runs with its own data files that says what to print, draw, or find the data of cross sections, solar flux ...
c	Again, this way of proceeding can be costly in time, but more comfortable to use than go through commons which regulate the switches.
c	DO NOT MODIFY THIS WAY TO MAKE if you want an easy followed this 'black box' of transport (in particular releases).
c
c 	Les donnees necessaires d'un code a l'autre se font par l'inter
c 	mediaire de fichiers non formattes. Cette methode est peut
c 	etre couteuse en temps, mais tres pratique.
c 	Chaque programme tourne avec son propre fichiers de donnees
c	qui dit quoi imprimer, dessiner, ou trouver les donnees de
c	sections efficaces, de flux solaire... Encore une fois, cette
c 	facon de proceder peut etre couteuse en temps, mais beaucoup
c 	plus commode a l'utilisation que passer par des commons qui
c 	reglent les switches.
c 	NE PAS MODIFIER CETTE FACON DE FAIRE si on veut un suivit
c 	facile de cette 'boite noire' du transport (en particulier
c 	des releases).
c
c ====================================================================
c Computational parameters :
c ====================================================================
c nbren    =    IPN: max. length of the energy grid
c nen      =    IPN: actual length of the energy grid
c nbralt   =    IPM:(MMAX) length of altitude grid (number of layers +1)
c nalt     =    actual # of altitudes
c nbrang   =    maximum number of streams
c nbrango2 =    one half of the maximum number of streams
c nang     =    actual number of stream (must be less or equal 16;
c               should preferably be a multiple of two, if more than 16
c               streams are required,recompile all subroutines with
c               larger arrays)
c nango2   =    one half of the actual number of streams
c nbrsp    =    max # of species (1=N2 , 2=O2 , 3=O , 4=H , 5=He)
c nspec    =    actual # of species dans l'ordre(imperatif) N2,O2,O,H,He
c nbrionst =    number of ionized states
c nbrexc   =    maximum number of excitation states
c
c       Les angles descendants vont de 0 a
c       90 degres et les angles montant de 90 a 180 degres.
c       gwt : gaussian weigths (         1 ...    nango2 : up,
c                               nbrango2+1 ...  2*nango2 : down)
c       gmu : gaussian angles
c
c       The up and downward intensity, flux etc is defined in terms of
c       positive and negative mu. My definition is, however, independent
c       of the direction of the magnetic field and thus a bit arbitrary.
c       On the northern hemisphere the field is pointing down, and
c       thus a pitch angle of 0 degrees (mu=1) would be down and a pitch
c       angle of 180 degrees (mu=-1) would be pointing up.  However, I
c       define the pitch angle 90-180 (mu=[0,-1]) to be down, and the
c       pitch angle of 0-90 (mu=[0,+1]) up.  This way the transport code
c       doesn't care about the hemisphere anymore.
c       The program is built after the Northern hemisphere assumption,
c       i.e. {0,90} degrees --> downward, and {90,180} degrees -->
c       upward.
c
c ====================================================================
c
        implicit none
c
        integer npt
c
        include 'TRANSPORT.INC'
c
        integer nspec,nalt,jpreci0,jpreci,modatmos,neutspe
        real zbot,ztop,hrloc,ut,year,tempexo,f107(3),Apind,day,
     . 	 	glat,glong,albedo,altcm(nbralt),altkm(nbralt),
     .		tneutre(nbralt),densneut(8,nbralt),
     .     	colden(8,nbralt)
      integer knm,nang,nango2,nen
      real botE(nbren),centE(nbren),ddeng(nbren)
      real angzb(2*nbrango2),gmu(2*nbrango2),gwt(2*nbrango2)
      real fluxdown(nbren,nbrango2),fluxup(nbren,nbrango2)
      real denelc(nbralt),temelc(nbralt),dipang(nbralt),
     .	       smgdpa(nbralt),temion(nbralt),chideg
        real prodiontot(nbrsp*2,nbralt),chaufelec(nbralt)
        real Ne_supra(nbralt),courant_supra(nbralt),Te_supra(nbralt),
     .          Chaleur_supra(nbralt)
c
           integer i,j,iyd,nx
        real z(npt),Ne(npt),Te(npt),ap(7),stl
        real Tj(npt),chi,pideg,dTinf,stepnrj,anormnrj
        real UTsec,dz
        real HQe_1,HPo_1,HPo2_1,HPn2_1,HPh_1,flux
        real Eave
         real zlim,zlim_1

        real Nh(npt),No(npt),No2(npt),Nn2(npt),Nn(npt),Tn(npt)
        real Ne_sup(npt),courant_sup(npt),Te_sup(npt),Chaleur_sup(npt)

        !Variables for photodissociation of O2
        integer npt2
        parameter (npt2=500)
        real phdisso2(500),pfluxsr(8,201)
        real Po1sdisso2(npt2)
        common/photodissociation/phdisso2,Po1sdisso2
        common/kininds/nalt,nspec,nen
        !-----MZ

         integer kiappel
        integer ien,ialt,iang,isp

        real coef
c
        integer indlim
c
        real Ph(npt),Po(npt),Po2(npt),Pn2(npt),Pn(npt)
        real Heat(npt)

        common/exo/dTinf

c
       data pideg/57.29578/
c
1000   format (a)
c
c ====================================================================
c 	Lecture des parametres d'entree pour le transport
c ====================================================================
c ---- 	Identification des grilles
c 	knm 	= identification du run(sert aux impressions ou dessins)
c 	zbot 	= altitude min (km)
c 	ztop 	= altitude max (km)
c 	altkm 	= grille d'altitudes, sens decroissant (km)
c 	alt 	= grille d'altitudes, sens decroissant (cm)
c 	botE 	= Energie basse de la grille d'energie (eV).
c 		  L'energie la plus basse doit etre = a 0 eV.
c 		  Sert au rangement des photoelectrons dans la grille.
c 		  Les energies doivent etre en ordre croissant.
c 	centE 	= Energie centrale de la grille d'energie (eV).
c 		  L'energie la plus basse doit etre <= a 1 eV.
c 	ddeng	= largeur de chaque grille d'energie.
c 	angzb	= grille d'angles en degres (en nombre nang)
c 		  Doit etre une grille gaussienne pour les integrations
c 		  Ordre croissant de 0 a 180 degres.
c 		  {0->90=down},{90->180=up}
c 	gmu	= cosinus (grille d'angles) (en nombre nang)
c 	gwt	= Poids gaussiens de la grille d'angles (en nombre nang)
c ----	Parametres physiques
c 	hrloc	= heure decimale locale
c 	ut	= heure universelle
c 	day	= jour
c 	year 	= annee
c 	tempexo = temperature exospherique
c 	f107, f107a = ...
c 	Apind	= indice Ap
c 	chideg  = angle solaire zenithal en degres (inutile si on
c 		  n'appelle pas la photoionisation)
c 	glat  	= latitude (Tromso = 69.5)
c 	glong  	= longitude (Tromso = 19.2)
c 	tneutre = temperature neutre sur la grille altkm
c 	densneut= densite des neutres en nombre neutspe (cm-3)
c 		  ATTENTION A LA DIMENSION ! densneut est dimensionne
c 		  en (8,nbralt). 8 correspond au nombre max de neutres
c 		  dans msis, plus NO que je peux calculer par ailleurs.
c 		  Le transport se calcul sur un nombre max. de 5
c 		  especes (= nbrsp), mais pour d'autres applications,
c 		  il est important de conserver ce dimensionnement.
c 	colden  = densite colonne des neutres en nombre neutspe (cm-2)
c 		  ATTENTION A LA DIMENSION ! colden est dimensionne
c 		  en (8,nbralt) comme densneut.
c 	denelc	= densite electronique (sert pour le calcul de la
c 		  friction, cm-3)
c 	temelc	= temperature electronique (sert pour le calcul de la
c 		  friction, K)
c 	temion	= temperature ionique (sert pour le calcul des
c 	 	  conductivites (dans les frequences de collisions).
c 	dipang	= Magnetic dip angle (xmgdpa), [degres]
c 	smgdpa 	= sin{Magnetic deep angle (xmgdpa)}
c 	fluxdown= Flux descendant (cm-2.s-1.eV-1.sr-1), dans le sens
c 	 	  des energies croissantes.
c 	fluxup  = Flux montant (cm-2.s-1.eV-1.sr-1). Ne sert pas au
c 		  calcul lui meme, mais pour un test de comparaison
c 		  entre cette mesure eventuelle et le calcul
c 	Pour fluxdown et fluxup, on imagine un satellite qui tourne
c 	et qui mesure en fluxdown(1) le flux descendant //B, puis
c 	en fluxdown(nang/2) le flux descendant proche de perp. B,
c 	puis en fluxup(1) le flux montant proche de perp. B et enfin
c 	en fluxup(nang/2) le flux montant //B
c 	L'indice des angles (ainsi que leurs cosinus et poids) va
c 	pendant ce temps de 1 a nang), et les angles de pres de 0 a
c 	pres de 180 degres.
c 	Le programme de transport remet ces tableau dans l'ordre qui
c 	lui est digerable (different). Cela prend un peu de temps,
c 	mais aide dans le cas (comme pour Viking) ou on a a lire
c 	directement des donnees satellites.
c ----	Conditions du run
c 	jpreci = 0 if sun only
c 	       = 1 if electron precipitation only
c 	       = 2 if sun + electron precipitations
c	       = 3 if proton precipitation only
c	       = 4 if proton and electron precipitations
c	       = 5 if surn + proton precipitations
c	       = 6 if proton, electron precipitations + sun
c 	albedo  = charge la condition limite basse (la condition haute
c 		  etant le flux precipite). Dit quelle proportion de
c 		  particules remontent de la couche au dessous de l'
c 		  altitude la plus basse. Quand cette altitude zbot
c 		  est en region E, albedo peut etre n'importe quoi entre
c 		  0 et 1 (tout est local). Mais si zbot est en region
c 		  F, il faut faire differents essais pour en voir l'
c 		  influence.
c 		  Albedo conseille : 1
c 	 	  Si le flux descendant par l'altitude la plus basse est
c 		  trop eleve, il apparait un warning.
c
c 	Sorties du transport :
c 	----------------------
c
c 	prodiontot(sp,z) =  prodionprim(sp,z) + prodionsec(sp,z)
c                       prodiontot(ionspe=1,iz)--->N2+
c                       prodiontot(ionspe=2,iz)--->O2+
c                       prodiontot(ionspe=3,iz)--->O+
c                       prodiontot(ionspe=4,iz)--->N+
c                       prodiontot(ionspe=5,iz)--->H+
c                       prodiontot(ionspe=6,iz)--->He+
c 	chaufelec = chauffage electronique par perte continue (Heat dans
c 	       trans.f
c 	Ne_supra(z) = 1er moment : Ne suprathermique [cm-3]
c	courant_supra(z) = 2eme moment : courant suprathermique
c 			[cm-2.s-1]
c	Te_supra(z) = 3eme moment : Te suprathermique [K]
c	Chaleur_supra(z) = 4eme moment : flux d'energy suprathermique
c		           (Heat flux) [eV.cm-2.s-1]
c
c ====================================================================
c 	Initialisation des entrees (selon qui appelle)
c ====================================================================
c
c
c	if(kiappel.eq.1)write(6,*)'transelec, appele par transsolo' 'transelec called by transsolo'
c	if(kiappel.eq.2)write(6,*)'transelec, appele par transcar'  'transelec called by transcar'
c	write(6,*)
c
       if (kiappel==1) then
c
c 	  On est appele par un transsolo.f. Les entrees sont lues dans
c 	  ELEC et NEUTRAL
c	  It is called by transsolo.f. The entries are read and ELEC NEUTRAL.

          write(6,*)
          write(6,*)'lect.f : reading the inflow of transport.f'
          write(6,*)'-------'
          print*,'call lect'
          call lect (nspec,knm,nen,nalt,zbot,ztop,hrloc,UT,day,year,
     .     jpreci,tempexo,f107(2),f107(3),Apind,chi,chideg,glat,glong,
     .          albedo,altkm,altcm,tneutre,densneut,colden,botE,centE,
     .          ddeng,nang,nango2,angzb,gmu,gwt,fluxdown,fluxup,
     .          denelc,temelc,temion,dipang,smgdpa)
         ap(1)=Apind
c
       elseif (kiappel.eq.2) then
c 	  On est appele par le transport fluide
         jpreci = jpreci0
            print*,'call iniflu'
            call iniflu(npt,iyd,UTsec,z,glat,glong,stl,f107,
     .                ap,chi,Ne,Te,Tj,indlim,jpreci,
     .                Nh,No,No2,Nn2,Nn,Tn,Po,Po2,Pn2,Ph,Pn,Heat,
     .
     .                  nspec,knm,nen,nang,nango2,nalt,
     .                  ddeng,botE,centE,gmu,gwt,angzb,altkm,altcm,
     .                  dipang,smgdpa,
     .                  fluxup,fluxdown,densneut,tneutre,tempexo,
     .                  albedo,chideg,denelc,temelc,temion,UT,hrloc,
     .                  ztop,zbot,colden,day,year)
c
        else
          write(6,*)'kiappel is false'
          error stop
c
      endif            ! endif kiappel

c
c ====================================================================
c 	Calcul de la degradation en energie
c	Calculation of degradation in energy
c ====================================================================
      print*,'call degrad'
        call degrad(knm,nen,centE,botE,ddeng,nspec,kiappel)
c
c ====================================================================
c 	Calcul de la photoproduction primaire
c	Calculation of primary photoproduction
c ====================================================================
c
       if(jpreci.ne.1 .and. jpreci.ne.3 .and. jpreci.ne.4)
     .  call felin(knm,nspec,hrloc,day,year,UT,
     .  tempexo,f107,ap,glat,glong,nen,botE,centE,
     .  ddeng,nalt,altkm,tneutre,densneut,colden,chi,chideg,
     .          kiappel,phdisso2,pfluxsr,Po1sdisso2)
c
c ====================================================================
c 	Transport : calcul du flux stationnaire d'electrons
c	Transport: Calculation of the steady flow of electrons
c ====================================================================
c
c
        call trans(knm,nspec,nalt,zbot,ztop,hrloc,day,year,jpreci,
     .        tempexo,f107,ap,chideg,glat,glong,albedo,
     .        altkm,altcm,tneutre,densneut,colden,nang,nango2,
     .        angzb,gmu,gwt,nen,centE,botE,ddeng,fluxdown,fluxup,denelc,
     .        temelc,temion,smgdpa,prodiontot,chaufelec,kiappel,
     .        Ne_supra,courant_supra,Te_supra,Chaleur_supra,ut)
c
c ====================================================================
c 	Integration des productions et flux chaleur
c	Integration of production and heat flow
c ====================================================================
c
c 	Uniquement pour le transport fluide
c	Solely for fluid transportation
      if (kiappel.eq.2) then
            print*,'call cineout'
           call cineout(nalt,chaufelec,denelc,prodiontot,
     .          Ne_supra,courant_supra,Te_supra,Chaleur_supra,
     .      	Ne,npt,indlim,nx,zlim,zlim_1,z,Heat,Ph,Po,Po2,Pn2,Pn,
     .          Ne_sup,courant_sup,Te_sup,Chaleur_sup)

      end if
      end subroutine transelec


subroutine elloss(mass,igb,ikk,igglf,W, &
& vol,pi,nwpt,wmax,nbocc,ncband,ngkpt, &
& kg,kgq,enrgy,enrgyq,cg,cgq,npwt,npwtq,bantot,bantotq,ncg,ncgq, &
& indxkpw,indxkpwq,indxkbnd,indxkbndq,indxkcg,indxkcgq,npwarr,npwarrq, &
& kpt,kptq,nkpt,nkptq,nqpt,nsymk,nsymkq,symk,symkq,nsym,nsymq,symrel,syminv, &
& ihlf,ihlfq,lvtrans,lvtransq,bmet,ipwlf,npwlf,ipwndx,npwndx,ntpwndx, &
& npwup,invpw2ndx,pwsymndx,iqsymndx, &
& igmx,igmn,igndx,igndxq,ikndx,ikndxq,iqndx,isymndx,isymndxq,npw,npwq, &
& nband,nbandq,nsppol,shiftk,shiftkq,cse,strate)
implicit none
integer :: igb(3),ikk(3),igglf(3),nwpt,nbocc,ncband,ngkpt(3)
integer :: igmn(3),igmx(3)
integer :: npwt,npwtq,bantot,bantotq,ncg,ncgq,nkpt,nkptq,nqpt,nsym,nsymq,nsppol
integer :: npw,npwq,ipw1,npwlf,npwndx,ntpwndx
double precision :: mass,vol,pi,wmax
double complex :: W(nwpt,nqpt,ntpwndx)
integer :: kg(3,npwt),kgq(3,npwtq)
double precision :: enrgy(bantot),enrgyq(bantotq)
double complex :: cg(ncg),cgq(ncgq)
integer :: indxkpw(nkpt),indxkpwq(nkptq),indxkbnd(nkpt),indxkbndq(nkptq)
integer :: indxkcg(nkpt),indxkcgq(nkptq),npwarr(nkpt),npwarrq(nkptq)
double precision :: kpt(3,nkpt),kptq(3,nkptq),shiftk(3),shiftkq(3)
integer :: nsymk(nkpt),nsymkq(nkptq),symk(nkpt,nsym*2),symkq(nkptq,nsymq*2)
integer :: symrel(3,3,nsym),syminv(3,3,nsymq)
integer :: lvtrans(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: lvtransq(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ihlf(nkpt),ihlfq(nkptq)
double precision :: bmet(3,3)
integer :: ipwlf(3,npwlf),ipwndx(2,ntpwndx)
integer :: igndx(nkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: igndxq(nkptq,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: ikndx(ngkpt(1),ngkpt(2),ngkpt(3)),ikndxq(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: iqndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymndx(ngkpt(1),ngkpt(2),ngkpt(3)),isymndxq(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: nband(nkpt*nsppol),nbandq(nkptq*nsppol)
double complex :: sei,seipw
double precision :: strate
double complex :: ssi(nwpt),ssc(nwpt),cse
integer :: ii,jj,kk,ix,iy,iz,iqq(3),iqqp(3),jka(3),jkk(3),iskip
integer :: ikpt,ikptq,iks(3),ikslf1(3),ikslf2(3)
integer :: igg(3),igh(3),igg0(3),icenter,isym,isymq,iqpt,iqsym,iw
double precision :: xck(3),xckq(3)
double complex :: cmatel,cmatel2,vqmat2(ngkpt(1),ngkpt(2),ngkpt(3))
double complex :: vfactor(ngkpt(1),ngkpt(2),ngkpt(3)),vfv(8),lossv(8)
double precision :: vq2(8)
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3))
double precision :: whi,wlo,ww,enval(8),dw
double precision :: abr,rlr
double complex :: tseincr,tseincrx,dse
integer :: iwh,iwl,ibmin,ibmax
double precision :: vq,qq(3),qp(3),qq2,qp2,qs(3),xk(3),xkmq(3),ek,ekmq
double precision :: stvec(ngkpt(3)),stvec2(ngkpt(3)),seiold,seibc
integer :: npwup,iipw,jjpw
integer :: iqsymndx(ngkpt(1),ngkpt(2),ngkpt(3)),invpw2ndx(npwup,npwup)
integer :: pwsymndx(npwup,2*nsym)
integer :: ipw2,jw
double precision :: ww1,ww2
integer :: idum
double precision :: xdum

abr=1.d-6
rlr=1.d-6
sei=0.d0
strate=0.d0
cse=(0.d0,0.d0)
igg0=(/0,0,0/)
do iw=1,nwpt
  ssi(iw)=(0.d0,0.d0)
  ssc(iw)=(0.d0,0.d0)
enddo
dw=wmax/dble(nwpt)
ikpt=ikndx(ikk(1),ikk(2),ikk(3))
isym=isymndx(ikk(1),ikk(2),ikk(3))
do ii=1,3
  xk(ii)=igb(ii)+kpt(ii,ikpt)
enddo
call fek(xk,bmet,ek)
ek=ek/mass
  seibc=sei
  iskip=1
  do iipw=1,ntpwndx
!  do iipw=1,1
!    write(6,'(a,i4)') 'iipw ',iipw
    seipw=sei
    ipw1=ipwndx(1,iipw)
    ipw2=ipwndx(2,iipw)
    if (ipw1.ne.ipw2) cycle
!    xdum=1.d26
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
      iqq=(/ix,iy,iz/)
      do ii=1,3
        iks(ii)=iqq(ii)-ngkpt(ii)/2
        ikslf1(ii)=iks(ii)+ipwlf(ii,ipw1)*ngkpt(ii)
      enddo
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        call fqq(shiftk,shiftkq,ikslf1,ngkpt,qq,qs)
      else
        call fqq(shiftk,shiftk,ikslf1,ngkpt,qq,qs)
      endif
      do ii=1,3
        jka(ii)=ikk(ii)-iks(ii)
        jkk(ii)=mod(jka(ii)-1,ngkpt(ii))+1
        if (jkk(ii).le.0) jkk(ii)=jkk(ii)+ngkpt(ii)
        xck(ii)=dble(ikk(ii))/dble(ngkpt(ii))+shiftk(ii)/dble(ngkpt(ii))
        xck(ii)=mod(xck(ii),1.d0)
        if (xck(ii).lt.0.d0) xck(ii)=xck(ii)+1
        xck(ii)=1.d0-mod(1.d0-xck(ii),1.d0)
        xck(ii)=xck(ii)-0.5d0
        xckq(ii)=dble(jkk(ii))/dble(ngkpt(ii))+shiftkq(ii)/dble(ngkpt(ii))
        xckq(ii)=mod(xckq(ii),1.d0)
        if (xckq(ii).lt.0.d0) xckq(ii)=xckq(ii)+1
        xckq(ii)=1.d0-mod(1.d0-xckq(ii),1.d0)
        xckq(ii)=xckq(ii)-0.5d0
        igg(ii)=nint(xckq(ii)-xck(ii)+qq(ii))
      enddo
      ikptq=ikndxq(jkk(1),jkk(2),jkk(3))
      isymq=isymndxq(jkk(1),jkk(2),jkk(3))
      do ii=1,3
        xkmq(ii)=xk(ii)-qq(ii)
      enddo
      call fek(xkmq,bmet,ekmq)
      ekmq=ekmq/mass
      omega(iqq(1),iqq(2),iqq(3))=ek-ekmq
      if (omega(iqq(1),iqq(2),iqq(3)).gt.0.d0) iskip=0
    enddo
!    write(75,'(10f8.2)') stvec(:)*27.2113845d0
!    write(75,'(10f8.4)') stvec(:)
    enddo
!    write(75,*) iqq(1)+1,'--------------------------------------------------'
    enddo
    if (iskip.eq.1) cycle
    write(6,'(38x,i3,14x,2i3)') ipw1
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=2,2
!    do iy=2,2
!    do iz=4,5
      iqq=(/ix,iy,iz/)
      do ii=1,3
        iks(ii)=iqq(ii)-ngkpt(ii)/2
        ikslf1(ii)=iks(ii)+ipwlf(ii,ipw1)*ngkpt(ii)
        ikslf2(ii)=iks(ii)+ipwlf(ii,ipw2)*ngkpt(ii)
      enddo
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        call fqq(shiftk,shiftkq,ikslf1,ngkpt,qq,qs)
        call fqq(shiftk,shiftkq,ikslf2,ngkpt,qp,qs)
      else
        call fqq(shiftk,shiftk,ikslf1,ngkpt,qq,qs)
        call fqq(shiftk,shiftk,ikslf2,ngkpt,qp,qs)
      endif
      qq2=0.d0
      qp2=0.d0
      do ii=1,3
      do jj=1,3
        qq2=qq2+qq(ii)*bmet(ii,jj)*qq(jj)
        qp2=qp2+qp(ii)*bmet(ii,jj)*qp(jj)
      enddo
      enddo
      vq=4.d0*pi/sqrt(qq2*qp2)
!write(6,*) '>>>>> iqq = ',iqq
!write(6,*) 'ikslf1 = ',ikslf1
!write(6,*) 'ikslf2 = ',ikslf2
!write(6,*) 'qq = ',qq
!write(6,*) 'qp = ',qp
!write(6,*) 'qq2 = ',qq2
!write(6,*) 'qp2 = ',qp2
!write(6,*) 'vq = ',vq
      vqmat2(iqq(1),iqq(2),iqq(3))=vq
!write(6,*) 'cmatel  = ',cmatel
!write(6,*) 'cmatel2 = ',cmatel2
!write(6,*) 'vqmat2 = ',vqmat2(iqq(1),iqq(2),iqq(3))
!write(56,*) '>>>>>',iqq,vqmat2(iqq(1),iqq(2),iqq(3))
!      stvec(iqq(3))=vq
!      stvec(iqq(3))=dble(vqmat2(iqq(1),iqq(2),iqq(3)))
!      stvec2(iqq(3))=dimag(vqmat2(iqq(1),iqq(2),iqq(3)))
!      stvec(iqq(3))=dble(cmatel)
!      stvec2(iqq(3))=dimag(cmatel)
!      stvec(iqq(3))=dble(cmatel2)
!      stvec2(iqq(3))=dimag(cmatel2)
!      stvec(iqq(3))=dble(cmatel*conjg(cmatel))
    enddo
!    write(76,'(10f8.2)') stvec(:)
!    write(76,'(10es8.1)') stvec(:)
!    write(76,'(10es8.1)') stvec2(:)
!    write(76,*)
    enddo
!    write(76,*) iqq(1)+1,'--------------------------------------------------'
    enddo
!    stop
    do iw=1,nwpt
      do ix=1,ngkpt(1)
      do iy=1,ngkpt(2)
      do iz=1,ngkpt(3)
!      do ix=1,1
!      do iy=1,1
!      do iz=3,3
        iqq=(/ix,iy,iz/)
        iqpt=iqndx(iqq(1),iqq(2),iqq(3))
        call locateelement(iqq,ipw1,ipw2,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
        if (jjpw.ne.0) then
          vfactor(iqq(1),iqq(2),iqq(3))=vqmat2(iqq(1),iqq(2),iqq(3))*dimag(W(iw,iqpt,jjpw))
        else
          vfactor(iqq(1),iqq(2),iqq(3))=(0.d0,0.d0)
        endif
!        stvec(iqq(3))=dble(vfactor(iqq(1),iqq(2),iqq(3)))
!        stvec2(iqq(3))=dimag(vfactor(iqq(1),iqq(2),iqq(3)))
!        stvec(iqq(3))=dimag(W(iw,iqpt,jjpw))
!        stvec(iqq(3))=dble(iqpt)
!        stvec2(iqq(3))=dble(jjpw)
      enddo
!      write(77,'(10es8.1)') stvec(:)
!      write(77,'(10es8.1)') stvec2(:)
!      write(77,'(10i8)') nint(stvec(:))
!      write(77,'(10i8)') nint(stvec2(:))
!      write(77,*)
      enddo
!      write(77,*) iqq(1)+1,'--------------------------------------------------'
      enddo
      seiold=sei
      do ix=1,ngkpt(1)
      do iy=1,ngkpt(2)
      do iz=1,ngkpt(3)
!      do ix=3,3
!      do iy=1,1
!      do iz=10,10
        iqq=(/ix,iy,iz/)
        call fhilo(omega,iqq,ngkpt,whi,wlo)
        iwh=min(nint(whi*dble(nwpt)/wmax),nwpt)
        iwl=nint(wlo*dble(nwpt)/wmax)
        if (iwl.gt.nwpt) cycle
        call fval(omega,iqq,iqqp,ngkpt,enval)
        call fpol(vfactor,ngkpt,iqq,iqqp,vfv)
        ww=iw*dw
!        write(42,*) '>>>>',iqq,ww
!        write(42,*)
!        write(42,'(2es12.3,2(4x,2es12.3))') enval(1:2),dble(vfv(1:2)),dimag(vfv(1:2))
!        write(42,'(2es12.3,2(4x,2es12.3))') enval(3:4),dble(vfv(3:4)),dimag(vfv(3:4))
!        write(42,*)
!        write(42,'(2es12.3,2(4x,2es12.3))') enval(5:6),dble(vfv(5:6)),dimag(vfv(5:6))
!        write(42,'(2es12.3,2(4x,2es12.3))') enval(7:8),dble(vfv(7:8)),dimag(vfv(7:8))
!        write(42,*)
        call cubeint(enval,ww,vfv,tseincr)
!        write(42,*) tseincr
        call fcenter(iqq,ngkpt,icenter)
        if (abs(tseincr).ne.0.d0) then
          rlr=1.d-2
          abr=1.d-2
!          write(6,*) ix,iy,iz
!          write(6,*) tseincr
!          call floss(W,nwpt,nqpt,iw,ngkpt,iqndx,iqq,lossv)
          call fvq2(iqq,shiftk,shiftkq,bmet,ngkpt,ipw1,ipw2,ipwlf,npwlf,vq2)
!          write(42,*)
!          write(42,'(2es12.3,2x,2(3x,2es12.3))') vq2(1:2),dble(vfv(1:2)),dimag(vfv(1:2))
!          write(42,'(2es12.3,2x,2(3x,2es12.3))') vq2(3:4),dble(vfv(3:4)),dimag(vfv(3:4))
!          write(42,*)
!          write(42,'(2es12.3,2x,2(3x,2es12.3))') vq2(5:6),dble(vfv(5:6)),dimag(vfv(5:6))
!          write(42,'(2es12.3,2x,2(3x,2es12.3))') vq2(7:8),dble(vfv(7:8)),dimag(vfv(7:8))
!          write(42,*)
          lossv=vfv*vq2/(4.d0*pi)
          call subint(mass,ikk,igb,xk,iqq,shiftk,shiftkq,lossv,ww,iw,bmet,iqndx,ngkpt,nwpt,nqpt,ek,ikndxq,vol,ipw1,ipwlf,npwlf,pi,rlr,abr,tseincr)
!          write(6,*) tseincr
        endif
!        write(42,*) tseincr
        dse=tseincr/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol)
        sei=sei+dse*dw/pi
        strate=strate+2.d0*dse*ww*dw
        ssi(iw)=ssi(iw)+dse
!        write(66,'(3i4,5x,es10.3)') iqq,dse
!        write(66,'(3i4,5x,f20.6)') iqq,dble(dse)*27.2114
!        write(66,'(3i4,a)') iqq,'-----------------------------------------------'
!        write(66,'(es10.3,5x,2es10.3)') ww,dse
!        write(66,*)
!        write(66,'(2es10.3,5x,2es10.3)') dble(vfv(1:2)),enval(1:2)-ww
!        write(66,'(2es10.3,5x,2es10.3)') dble(vfv(3:4)),enval(3:4)-ww
!        write(66,*)
!        write(66,'(2es10.3,5x,2es10.3)') dble(vfv(5:6)),enval(5:6)-ww
!        write(66,'(2es10.3,5x,2es10.3)') dble(vfv(7:8)),enval(7:8)-ww
!        write(42,*) ssi(iw)
!        stvec(iqq(3))=dble(tseincr)
!        stvec2(iqq(3))=dimag(tseincr)
!        stvec(iqq(3))=dble(icenter)
      enddo
!      write(78,'(10es8.1)') stvec(:)
!      write(78,'(10es8.1)') stvec2(:)
!      write(78,*)
!      write(78,'(10i4)') nint(stvec(:))
      enddo
!      write(78,*) iqq(1)+1,'--------------------------------------------------'
      enddo
!      write(67,'(i4,f10.3,5x,2es10.3,5x,2es10.3)') iw,ww*27.2114,(sei-seiold)*27.2114,sei*27.2114
    enddo
    write(6,*) iipw,(sei-seipw)*pi*27.2114
  enddo
!  write(68,'(2i3,2f10.3)') (sei-seibc)*27.2114,sei*27.2114

do iw=1,nwpt
  ww1=dble(iw)*dw
  do jw=1,nwpt
    if (iw.eq.jw) cycle
    ww2=dble(jw)*dw
    ssc(iw)=ssc(iw)+2.d0*ssi(jw)*dw*(ww2/(ww2**2-ww1**2))
  enddo
  ssc(iw)=ssc(iw)-(0.d0,pi)*ssi(iw)
  cse=cse+ssc(iw)*dw/pi
!  write(84,'(3es12.4)') ww1,ssi(iw)
enddo

return
end subroutine elloss