MODULE zdfmxl
  USE oce
  USE dom_oce
  USE trc_oce, ONLY: l_offline
  USE zdf_oce
  USE eosbn2
  USE in_out_manager
  USE prtctl
  USE phycst
  USE iom
  USE lib_mpp
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: zdf_mxl
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: nmln
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: hmld
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: hmlp
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: hmlpt
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, DIMENSION(:, :) :: hmld_zint
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, DIMENSION(:, :) :: htc_mld
  LOGICAL, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: ll_found
  LOGICAL, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ll_belowml
  REAL(KIND = wp), PUBLIC :: rho_c = 0.01_wp
  REAL(KIND = wp) :: avt_c = 5.E-4_wp
  TYPE, PUBLIC :: MXL_ZINT
    INTEGER :: mld_type
    REAL(KIND = wp) :: zref
    REAL(KIND = wp) :: dT_crit
    REAL(KIND = wp) :: iso_frac
  END TYPE MXL_ZINT
  CONTAINS
  INTEGER FUNCTION zdf_mxl_alloc()
    zdf_mxl_alloc = 0
    IF (.NOT. ALLOCATED(nmln)) THEN
      ALLOCATE(nmln(jpi, jpj), hmld(jpi, jpj), hmlp(jpi, jpj), hmlpt(jpi, jpj), hmld_zint(jpi, jpj), htc_mld(jpi, jpj), ll_found(jpi, jpj), ll_belowml(jpi, jpj, jpk), STAT = zdf_mxl_alloc)
      IF (lk_mpp) CALL mpp_sum(zdf_mxl_alloc)
      IF (zdf_mxl_alloc /= 0) CALL ctl_warn('zdf_mxl_alloc: failed to allocate arrays.')
    END IF
  END FUNCTION zdf_mxl_alloc
  SUBROUTINE zdf_mxl(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk
    INTEGER :: iikn, iiki, ikt
    REAL(KIND = wp) :: zN2_c
    INTEGER, DIMENSION(jpi, jpj) :: imld
    IF (kt == nit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'zdf_mxl : mixed layer depth'
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~ '
      IF (zdf_mxl_alloc() /= 0) CALL ctl_stop('STOP', 'zdf_mxl : unable to allocate arrays')
    END IF
    !$ACC KERNELS
    nmln(:, :) = nlb10
    hmlp(:, :) = 0._wp
    zN2_c = grav * rho_c * r1_rau0
    DO jk = nlb10, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          ikt = mbkt(ji, jj)
          hmlp(ji, jj) = hmlp(ji, jj) + MAX(rn2b(ji, jj, jk), 0._wp) * e3w_n(ji, jj, jk)
          IF (hmlp(ji, jj) < zN2_c) nmln(ji, jj) = MIN(jk, ikt) + 1
        END DO
      END DO
    END DO
    imld(:, :) = mbkt(:, :) + 1
    DO jk = jpkm1, nlb10, - 1
      DO jj = 1, jpj
        DO ji = 1, jpi
          IF (avt(ji, jj, jk) < avt_c * wmask(ji, jj, jk)) imld(ji, jj) = jk
        END DO
      END DO
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        iiki = imld(ji, jj)
        iikn = nmln(ji, jj)
        hmld(ji, jj) = gdepw_n(ji, jj, iiki) * ssmask(ji, jj)
        hmlp(ji, jj) = gdepw_n(ji, jj, iikn) * ssmask(ji, jj)
        hmlpt(ji, jj) = gdept_n(ji, jj, iikn - 1) * ssmask(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    IF (.NOT. l_offline) THEN
      IF (iom_use("mldr10_1")) THEN
        IF (ln_isfcav) THEN
          CALL iom_put("mldr10_1", hmlp - risfdep)
        ELSE
          CALL iom_put("mldr10_1", hmlp)
        END IF
      END IF
      IF (iom_use("mldkz5")) THEN
        IF (ln_isfcav) THEN
          CALL iom_put("mldkz5", hmld - risfdep)
        ELSE
          CALL iom_put("mldkz5", hmld)
        END IF
      END IF
    END IF
    CALL zdf_mxl_zint(kt)
    IF (ln_ctl) CALL prt_ctl(tab2d_1 = REAL(nmln, wp), clinfo1 = ' nmln : ', tab2d_2 = hmlp, clinfo2 = ' hmlp : ')
  END SUBROUTINE zdf_mxl
  SUBROUTINE zdf_mxl_zint_mld(sf)
    TYPE(MXL_ZINT), INTENT(IN) :: sf
    INTEGER :: nn_mld_type
    REAL(KIND = wp) :: rn_zref
    REAL(KIND = wp) :: rn_dT_crit
    REAL(KIND = wp) :: rn_iso_frac
    REAL(KIND = wp), PARAMETER :: zepsilon = 1.E-30
    INTEGER, DIMENSION(jpi, jpj) :: ikmt
    INTEGER, DIMENSION(jpi, jpj) :: ik_ref
    INTEGER, DIMENSION(jpi, jpj) :: ik_iso
    REAL, DIMENSION(jpi, jpj, jpk) :: zT
    REAL, DIMENSION(jpi, jpj) :: ppzdep
    REAL, DIMENSION(jpi, jpj) :: zT_ref
    REAL :: zT_b
    REAL, DIMENSION(jpi, jpj, jpk) :: zdTdz
    REAL, DIMENSION(jpi, jpj, jpk) :: zmoddT
    REAL :: zdz
    REAL :: zdT
    REAL, DIMENSION(jpi, jpj) :: zdelta_T
    REAL, DIMENSION(jpi, jpj) :: zRHO1, zRHO2
    INTEGER :: ji, jj, jk
    nn_mld_type = sf % mld_type
    rn_zref = sf % zref
    rn_dT_crit = sf % dT_crit
    rn_iso_frac = sf % iso_frac
    IF (nn_mld_type == 0) THEN
      !$ACC KERNELS
      zdelta_T(:, :) = rn_dT_crit
      zT(:, :, :) = rhop(:, :, :)
      !$ACC END KERNELS
    ELSE IF (nn_mld_type == 1) THEN
      !$ACC KERNELS
      ppzdep(:, :) = 0.0
      !$ACC END KERNELS
      CALL eos(tsn(:, :, 1, :), ppzdep(:, :), zRHO1(:, :))
      !$ACC KERNELS
      zT(:, :, 1 : jpts) = tsn(:, :, 1, 1 : jpts)
      zT(:, :, jp_tem) = zT(:, :, 1) + rn_dT_crit
      !$ACC END KERNELS
      CALL eos(zT(:, :, 1 : jpts), ppzdep(:, :), zRHO2(:, :))
      !$ACC KERNELS
      zdelta_T(:, :) = ABS(zRHO1(:, :) - zRHO2(:, :)) * rau0
      !$ACC END KERNELS
      CALL lbc_lnk(zdelta_T, 'T', 1.)
      !$ACC KERNELS
      zT(:, :, :) = rhop(:, :, :)
      !$ACC END KERNELS
    ELSE
      !$ACC KERNELS
      zdelta_T(:, :) = rn_dT_crit
      zT(:, :, :) = tsn(:, :, :, jp_tem)
      !$ACC END KERNELS
    END IF
    !$ACC KERNELS
    DO jk = 1, jpk - 2
      zdTdz(:, :, jk) = (zT(:, :, jk + 1) - zT(:, :, jk)) / e3w_n(:, :, jk + 1)
      zmoddT(:, :, jk) = ABS(zT(:, :, jk + 1) - zT(:, :, jk))
    END DO
    !$ACC END KERNELS
    DO jk = jpkm1, 2, - 1
      WHERE (gdept_n(:, :, jk) > rn_zref)
        ik_ref(:, :) = jk - 1
        zT_ref(:, :) = zT(:, :, jk - 1) + zdTdz(:, :, jk - 1) * (rn_zref - gdept_n(:, :, jk - 1))
      END WHERE
    END DO
    WHERE (gdept_n(:, :, 1) > rn_zref)
      zT_ref = zT(:, :, 1)
      ik_ref = 1
    END WHERE
    !$ACC KERNELS
    ikmt(:, :) = mbkt(:, :) - 1
    ll_found(:, :) = .FALSE.
    !$ACC END KERNELS
    IF (rn_iso_frac - zepsilon > 0.) THEN
      !$ACC KERNELS
      ik_iso(:, :) = ik_ref(:, :)
      !$ACC END KERNELS
      DO jj = 1, nlcj
        DO ji = 1, nlci
          DO jk = ik_ref(ji, jj), ikmt(ji, jj) - 1
            IF (zmoddT(ji, jj, jk) > (rn_iso_frac * zdelta_T(ji, jj))) THEN
              ik_iso(ji, jj) = jk
              ll_found(ji, jj) = (zmoddT(ji, jj, jk) > zdelta_T(ji, jj))
              EXIT
            END IF
          END DO
        END DO
      END DO
      !$ACC KERNELS
      hmld_zint(:, :) = rn_zref
      DO jj = 1, jpj
        DO ji = 1, jpi
          IF (ll_found(ji, jj) .AND. tmask(ji, jj, 1) == 1.0) THEN
            zdz = ABS(zdelta_T(ji, jj) / zdTdz(ji, jj, ik_iso(ji, jj)))
            hmld_zint(ji, jj) = gdept_n(ji, jj, ik_iso(ji, jj)) + zdz
          END IF
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    WHERE (tmask(:, :, 1) /= 1.0)
      ll_found = .TRUE.
    END WHERE
    !$ACC KERNELS
    DO jk = 1, jpk
      ll_belowml(:, :, jk) = ABS(zT(:, :, jk) - zT_ref(:, :)) >= zdelta_T(:, :)
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        IF (.NOT. ll_found(ji, jj)) hmld_zint(ji, jj) = gdept_n(ji, jj, ikmt(ji, jj))
      END DO
    END DO
    !$ACC END KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        DO jk = ik_ref(ji, jj) + 1, ikmt(ji, jj)
          IF (ll_found(ji, jj)) EXIT
          IF (ll_belowml(ji, jj, jk)) THEN
            zT_b = zT_ref(ji, jj) + zdelta_T(ji, jj) * SIGN(1.0, zdTdz(ji, jj, jk - 1))
            zdT = zT_b - zT(ji, jj, jk - 1)
            zdz = zdT / zdTdz(ji, jj, jk - 1)
            hmld_zint(ji, jj) = gdept_n(ji, jj, jk - 1) + zdz
            EXIT
          END IF
        END DO
      END DO
    END DO
    !$ACC KERNELS
    hmld_zint(:, :) = hmld_zint(:, :) * tmask(:, :, 1)
    !$ACC END KERNELS
  END SUBROUTINE zdf_mxl_zint_mld
  SUBROUTINE zdf_mxl_zint_htc(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk
    INTEGER :: ikmax
    REAL(KIND = wp) :: zc, zcoef
    INTEGER, ALLOCATABLE, DIMENSION(:, :) :: ilevel
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :) :: zthick_0, zthick
    IF (.NOT. ALLOCATED(ilevel)) THEN
      ALLOCATE(ilevel(jpi, jpj), zthick_0(jpi, jpj), zthick(jpi, jpj), STAT = ji)
      IF (lk_mpp) CALL mpp_sum(ji)
      IF (ji /= 0) CALL ctl_stop('STOP', 'zdf_mxl_zint_htc : unable to allocate arrays')
    END IF
    !$ACC KERNELS
    ilevel(:, :) = 0
    zthick_0(:, :) = 0._wp
    !$ACC END KERNELS
    DO jk = 1, jpkm1
      !$ACC KERNELS
      DO jj = 1, jpj
        DO ji = 1, jpi
          zthick_0(ji, jj) = zthick_0(ji, jj) + e3t_n(ji, jj, jk)
          IF (zthick_0(ji, jj) < hmld_zint(ji, jj)) ilevel(ji, jj) = jk
        END DO
      END DO
      !$ACC END KERNELS
      WRITE(numout, FMT = *) 'zthick_0(jk =', jk, ') =', zthick_0(2, 2)
      WRITE(numout, FMT = *) 'gdepw_n(jk+1 =', jk + 1, ') =', gdepw_n(2, 2, jk + 1)
    END DO
    IF (ln_linssh) THEN
      !$ACC KERNELS
      zthick(:, :) = sshn(:, :)
      htc_mld(:, :) = tsn(:, :, 1, jp_tem) * sshn(:, :) * tmask(:, :, 1)
      !$ACC END KERNELS
    ELSE
      !$ACC KERNELS
      zthick(:, :) = 0._wp
      htc_mld(:, :) = 0._wp
      !$ACC END KERNELS
    END IF
    ikmax = MIN(MAXVAL(ilevel(:, :)), jpkm1)
    !$ACC KERNELS
    DO jk = 1, ikmax
      DO jj = 1, jpj
        DO ji = 1, jpi
          zc = e3t_n(ji, jj, jk) * REAL(MIN(MAX(0, ilevel(ji, jj) - jk + 1), 1))
          zthick(ji, jj) = zthick(ji, jj) + zc
          htc_mld(ji, jj) = htc_mld(ji, jj) + zc * tsn(ji, jj, jk, jp_tem) * tmask(ji, jj, jk)
        END DO
      END DO
    END DO
    zthick(:, :) = hmld_zint(:, :) - zthick(:, :)
    DO jj = 1, jpj
      DO ji = 1, jpi
        htc_mld(ji, jj) = htc_mld(ji, jj) + tsn(ji, jj, ilevel(ji, jj) + 1, jp_tem) * MIN(e3t_n(ji, jj, ilevel(ji, jj) + 1), zthick(ji, jj)) * tmask(ji, jj, ilevel(ji, jj) + 1)
      END DO
    END DO
    !$ACC END KERNELS
    WRITE(numout, FMT = *) 'htc_mld(after) =', htc_mld(2, 2)
    !$ACC KERNELS
    zcoef = rau0 * rcp
    htc_mld(:, :) = zcoef * htc_mld(:, :)
    !$ACC END KERNELS
  END SUBROUTINE zdf_mxl_zint_htc
  SUBROUTINE zdf_mxl_zint(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ios
    INTEGER :: jn
    INTEGER :: nn_mld_diag = 0
    CHARACTER(LEN = 1) :: cmld
    TYPE(MXL_ZINT) :: sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5
    TYPE(MXL_ZINT), SAVE, DIMENSION(5) :: mld_diags
    NAMELIST /namzdf_mldzint/ nn_mld_diag, sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5
    IF (kt == nit000) THEN
      REWIND(UNIT = numnam_ref)
      READ(numnam_ref, namzdf_mldzint, IOSTAT = ios, ERR = 901)
901   IF (ios /= 0) CALL ctl_nam(ios, 'namzdf_mldzint in reference namelist', lwp)
      REWIND(UNIT = numnam_cfg)
      READ(numnam_cfg, namzdf_mldzint, IOSTAT = ios, ERR = 902)
902   IF (ios /= 0) CALL ctl_nam(ios, 'namzdf_mldzint in configuration namelist', lwp)
      IF (lwm) WRITE(numond, namzdf_mldzint)
      IF (nn_mld_diag > 5) CALL ctl_stop('STOP', 'zdf_mxl_ini: Specify no more than 5 MLD definitions')
      mld_diags(1) = sn_mld1
      mld_diags(2) = sn_mld2
      mld_diags(3) = sn_mld3
      mld_diags(4) = sn_mld4
      mld_diags(5) = sn_mld5
      IF (lwp .AND. (nn_mld_diag > 0)) THEN
        WRITE(numout, FMT = *) '=============== Vertically-interpolated mixed layer ================'
        WRITE(numout, FMT = *) '(Diagnostic number, nn_mld_type, rn_zref, rn_dT_crit, rn_iso_frac)'
        DO jn = 1, nn_mld_diag
          WRITE(numout, FMT = *) 'MLD criterion', jn, ':'
          WRITE(numout, FMT = *) '    nn_mld_type =', mld_diags(jn) % mld_type
          WRITE(numout, FMT = *) '    rn_zref =', mld_diags(jn) % zref
          WRITE(numout, FMT = *) '    rn_dT_crit =', mld_diags(jn) % dT_crit
          WRITE(numout, FMT = *) '    rn_iso_frac =', mld_diags(jn) % iso_frac
        END DO
        WRITE(numout, FMT = *) '===================================================================='
      END IF
    END IF
    IF (nn_mld_diag > 0) THEN
      DO jn = 1, nn_mld_diag
        WRITE(cmld, FMT = '(I1)') jn
        IF (iom_use("mldzint_" // cmld) .OR. iom_use("mldhtc_" // cmld)) THEN
          CALL zdf_mxl_zint_mld(mld_diags(jn))
          IF (iom_use("mldzint_" // cmld)) THEN
            CALL iom_put("mldzint_" // cmld, hmld_zint(:, :))
          END IF
          IF (iom_use("mldhtc_" // cmld)) THEN
            CALL zdf_mxl_zint_htc(kt)
            CALL iom_put("mldhtc_" // cmld, htc_mld(:, :))
          END IF
        END IF
      END DO
    END IF
  END SUBROUTINE zdf_mxl_zint
END MODULE zdfmxl


!******************************************************************************
! Copyright c 2013, The Ames Laboratory, Iowa State University, and Rutgers
! University*.  All rights reserved.
!
! This software was authored by Yongxin Yao, Nicola Lanata*, Gabriel Kotliar*,
! Cai-Zhuang Wang, and Kai-Ming Ho, at The Ames Laboratory and
! Rutgers University and was supported by the U.S.
! Department of Energy (DOE), Office of Science,
! Basic Energy Sciences, Materials Science and Engineering Division.
! The Ames Laboratory is operated by Iowa State University for DOE
! under U.S. Government contract DE-AC02-07CH11358.
! The U.S. Government has the rights to use, reproduce, and
! distribute this software.
! NEITHER THE GOVERNMENT, THE AMES LABORATORY, IOWA STATE UNIVERSITY,
! NOR RUTGERS UNIVERSITY MAKES ANY WARRANTY,
! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE.
! If software is modified to produce derivative works,
! such modified software should be clearly marked,
! so as to not confuse it with the version available from
! The Ames Laboratory and Rutgers University.
!
! Additionally, redistribution and use in source and binary forms,
! with or without modification,
! are permitted provided that the following conditions are met:
!
!     Redistribution of source code must retain the above copyright notice,
!     this list of conditions, and the following disclaimer.
!
!     Redistribution in binary form must reproduce the above copyright notice,
!     this list of conditions, and the following disclaimer
!     in the documentation and/or other materials provided with distribution.
!
!     Neither the name of The Ames Laboratory, Iowa State University,
!     Rutgers University, the U.S. Government, nor the names of
!     its contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE AMES LABORATORY, IOWA STATE UNIVERSITY,
! RUTGERS UNIVERSITY, AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY
! AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE GOVERNMENT, THE AMES LABORATORY,
! IOWA STATE UNIVERSITY, RUTGERS UNIVERSITY, OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
! HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
! OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!******************************************************************************

module bandstru
    use gprec
    use gmpi
    use gutil
    use gconstant, only: d0,d1,z0,z1,zi,iu_kgen
    use ghdf5_base
    use warehouse
    use gtime
    implicit none

    type band_stru
        !< iso=2 => soc
        integer ispin_in,nspin_in
        integer n_frozen
        real(q) ehybrd,eband(2),ets2(2)
        !< ne(3). 1: total number of bands, 2-3: correlated bands interval
        integer,pointer :: ne(:,:,:)
        real(q),pointer :: ek(:,:,:) ! kohn-sham / gutz eigen values
        real(q),allocatable :: normso(:,:,:) ! list of spin-up/dn weights.
        complex(q),pointer :: r(:,:,:),la1(:,:,:),nc_phy(:,:,:),nks(:,:,:), &
                &d0(:,:,:),nrl(:,:,:) ! for onsite local 1pdm
        complex(q),pointer :: psi0_b(:,:,:) ! <bare psi0 | basis orbital>
        complex(q),pointer :: vk (:,:,:,:) ! eigen-vector
        complex(q),pointer :: hk0(:,:,:,:) ! lda bare dispersion
        integer nmax ! nmax: miximal number of bands
        integer nmaxin !< maximal number of bands inside the enrgy window.
        real(q),pointer :: ferwe(:,:,:),ferwer(:,:,:)
        !< fermi-weight, convention including kpt%wt and spin degeneracy
        real(q) :: eflda,nelet,nelel,nelec,mup_dn=0._q
        real(q) :: ef=0._q,nelet_frozen=0._q
        real(q) ebmin,ebmax,ebwidth
        complex(q),pointer::cwt(:,:,:)   ! occupation matrix for \rho
    end type band_stru

    type k_points
        integer::dim=-1,diml=-1,ismear,icor,ensemble=0
        real(q),pointer :: wt(:)=>null()
        real(q) twt,delta,cordeg
        character::file_name*512
    end type k_points

    type sym_info
        integer::nop,mode=0,ie
    end type sym_info

    type (band_stru) :: bnd
    type (sym_info)  :: sym
    type (k_points)  :: kpt

    contains

    subroutine set_bnd_info(io)
    integer,intent(in)::io

    integer iso,isp
    logical lexist

    bnd%nelet_frozen=sum(wh%fz(:)%nelect)
    bnd%n_frozen=sum(wh%fz(:)%nsorb)

    call gh5_open_r('GPARAMBANDS.h5',f_id)
    call gh5_read(iso,'/iso',f_id)
    call gh5_read(bnd%ispin_in,'/ispin',f_id)
    call gh5_read(kpt%dim,'/kptdim',f_id)
    call gh5_read(bnd%nmax,'/nbmax',f_id)
    wh%ispin_in=bnd%ispin_in
    if(io>0)then
        write(io,'(" ispin_in=",i2," iso=",i2, &
                &" ispin=",i2," ispo=",i2)')bnd%ispin_in, &
                &wh%iso,wh%ispin,wh%ispo
    endif
    if(iso==2.and.wh%ispin==2)then
        allocate(bnd%normso(bnd%nmax,2,kpt%dim))
        call gh5_read(bnd%normso,bnd%nmax,2,kpt%dim,'/normso',f_id)
    endif
    ! modify ispin_in for iso=2
    bnd%nspin_in=max(1, bnd%ispin_in/iso)
    allocate(bnd%ne(3,kpt%dim,bnd%nspin_in))
    call h5lexists_f(f_id,'/NE_LIST_SPIN1', &
            &lexist,gh5_err)
    if(lexist)then
        ! upper-case name: fortran convention
        do isp=1,bnd%nspin_in
            call gh5_read(bnd%ne(:,:,isp),3,kpt%dim,'/NE_LIST_SPIN'//&
                    &trim(int_to_str(isp)),f_id)
        enddo
    else
        bnd%ne(1,:,:)=bnd%nmax
        bnd%ne(2,:,:)=1
        bnd%ne(3,:,:)=bnd%nmax
    endif

    call h5lexists_f(f_id,'/ensemble',lexist,gh5_err)
    if(lexist)then
        call gh5_read(kpt%ensemble,'/ensemble',f_id)
    endif

    allocate(kpt%wt(kpt%dim))
    call gh5_read(kpt%wt,kpt%dim,'/kptwt',f_id)
    call gh5_read(kpt%ismear,'/ismear',f_id)
    call gh5_read(kpt%delta,'/delta',f_id)
    call gh5_read(bnd%nelet,'/nelectron',f_id)
    call h5lexists_f(f_id,'/kptfname',lexist,gh5_err)
    if(lexist)then
        call gh5_read(kpt%file_name,512,'/kptfname',f_id)
    endif
    call gh5_read(sym%nop,'/symnop',f_id)
    call gh5_read(sym%ie,'/symie',f_id)
    call gh5_read_wh_h1e(bnd%nspin_in)
    call gh5_close(f_id)
    call rotate_h1e_list()
    call calc_herm_matrices_pp(wh%h1e,'h1e',wh%hm,.false.,io,-1)
    kpt%twt=sum(kpt%wt)
    kpt%wt=kpt%wt/kpt%twt

    ! Consistence check
    if(wh%iso /= iso)then
        stop ' error in set_bnd_info: wh%iso /= bnd%iso!'
    endif

    bnd%nmaxin=maxval(bnd%ne(3,:,:)-bnd%ne(2,:,:)+1)
    if(io>0)then
        write(io,'(" min/max(bnd%ne(1,:,:))=",2i8)')minval(bnd%ne(1,:,:)), &
                &maxval(bnd%ne(1,:,:))
        write(io,'(" min/max(bnd%ne(2,:,:))=",2i8)')minval(bnd%ne(2,:,:)), &
                &maxval(bnd%ne(2,:,:))
        write(io,'(" min/max(bnd%ne(3,:,:))=",2i8)')minval(bnd%ne(3,:,:)), &
                &maxval(bnd%ne(3,:,:))
    endif

    bnd%nelec=0
    do isp=1,bnd%nspin_in
        bnd%nelec=bnd%nelec+sum((bnd%ne(2,:,isp)-1)*kpt%wt)*wh%rspo
    enddo
    bnd%nelel=bnd%nelet-bnd%nelec
    if(io>0)then
        write(io,'(" bnd%nmax=",i4)')bnd%nmax
        write(io,'(" valence electrons: total=",f8.1)')bnd%nelet
        write(io,'("         correlated block=",f8.1)')bnd%nelel
    endif
    call set_kpt_icor(io)
    return

    end subroutine set_bnd_info

    subroutine set_kpt_diml(nkpl)
    integer,intent(in)::nkpl

    kpt%diml=nkpl
    return

    end subroutine set_kpt_diml

    subroutine alloc_bnd()
    integer i

    if(kpt%diml<0)then
        write(0,'(" error in alloc_bnd: kpt%diml not set yet!")')
        stop
    endif
    allocate(bnd%ferwe (bnd%nmax,kpt%dim,wh%nspin))
    allocate(bnd%ferwer(bnd%nmax,kpt%dim,wh%nspin))
    allocate(bnd%ek(bnd%nmax,kpt%dim,wh%nspin))
    bnd%ek=0
    allocate(bnd%hk0(bnd%nmaxin**2,sym%nop,kpt%diml,bnd%nspin_in))
    allocate(bnd%vk (bnd%nmaxin**2,sym%nop,kpt%diml, &
            &wh%nspin))
    allocate(bnd%psi0_b(bnd%nmaxin**2,kpt%diml,bnd%nspin_in))
    bnd%psi0_b=0
    allocate(bnd%r(wh%nasotot,wh%nasotot,wh%nspin))
    bnd%r=0
    forall(i=1:wh%nasotot) bnd%r(i,i,:)=1._q
    allocate(bnd%d0 (wh%nasotot,wh%nasotot,wh%nspin))
    allocate(bnd%la1(wh%nasotot,wh%nasotot,wh%nspin))
    bnd%la1=0
    allocate(bnd%nc_phy(wh%nasotot,wh%nasotot,wh%nspin))
    allocate(bnd%nks(wh%nasotot,wh%nasotot,wh%nspin))
    allocate(bnd%nrl(wh%nasotot,wh%nasotot,wh%nspin))
    return

    end subroutine alloc_bnd

    subroutine read_bare_hamiltonian()
    integer ivec,ikp,ikpl,iks,nbtot,isym,nbands,isp
    complex(q),pointer::p_2d(:,:)

    ikpl=0
    do ivec=1,gp%nvec
        call gh5_open_r(file_name(gp%kvec(ivec,1),'BAREHAM'), f_id)
        do iks=1,gp%kvec(ivec,2)
            ikp=gp%kvec(ivec,3)+iks
            if(gp%ipar==1)then ! openmp
                ikpl=ikp
            else
                ikpl=ikpl+1
            endif
            do isp=1,bnd%nspin_in
                nbtot=bnd%ne(1,ikp,isp)
                call gh5_read(bnd%ek(1:nbtot,ikp,isp),nbtot,'/IKP_'// &
                        &trim(int_to_str(ikp))//'/ek0_spin'//&
                        &trim(int_to_str(isp)),f_id)
            enddo
            if(wh%iso==1.and.bnd%nspin_in==1.and.wh%nspin==2)then
                bnd%ek(1:nbtot,ikp,2)=bnd%ek(1:nbtot,ikp,1)
            endif
            do isp=1,bnd%nspin_in
                nbands=bnd%ne(3,ikp,isp)-bnd%ne(2,ikp,isp)+1
                p_2d(1:nbands,1:nbands)=>bnd%psi0_b(1:nbands**2,ikpl,isp)
                call gh5_read(p_2d,nbands,nbands, &
                        &'/IKP_'//trim(int_to_str(ikp))// &
                        &'/T_PSIK0_TO_HK0_BASIS_SPIN'// &
                        &trim(int_to_str(isp)),f_id)
                do isym=1,sym%nop
                    p_2d(1:nbands,1:nbands)=>bnd%hk0(1:nbands**2,isym, &
                            &ikpl,isp)
                    call gh5_read(p_2d,nbands,nbands, &
                            &'/IKP_'//trim(int_to_str(ikp))// &
                            &'/ISYM_'//trim(int_to_str(isym))//&
                            &'/HK0_SPIN'//trim(int_to_str(isp)),f_id)
                enddo
            enddo
        enddo
        call gh5_close(f_id)
    enddo
    nullify(p_2d)
#ifdef mpi_mode
    call dsum_all_mpi(bnd%ek,bnd%nmax*kpt%dim*wh%nspin)
#endif
    return

    end subroutine read_bare_hamiltonian

    ! rotate bare hamiltonian to symmetry-adapted basis.
    subroutine rotate_bare_hamiltonian()
    integer ivec,ikp,ikpl,iks,isym,nbands,isp
    complex(q),pointer::p_2d(:,:)

    ! check if necessary
    if(.not.associated(wh%db2sab))return

    ikpl=0
    do ivec=1,gp%nvec
        do iks=1,gp%kvec(ivec,2)
            ikp=gp%kvec(ivec,3)+iks
            if(gp%ipar==1)then
                ikpl=ikp
            else
                ikpl=ikpl+1
            endif
            do isp=1,bnd%nspin_in
                nbands=bnd%ne(3,ikp,isp)-bnd%ne(2,ikp,isp)+1
                p_2d(1:nbands,1:nbands)=>bnd%psi0_b(1:nbands**2,ikpl,isp)
                call site_wise_rtrans(p_2d,nbands,1)
                do isym=1,sym%nop
                    p_2d(1:nbands,1:nbands)=>bnd%hk0(1:nbands**2, &
                            &isym,ikpl,isp)
                    call site_wise_rtrans(p_2d,nbands,1)
                    p_2d=transpose(p_2d)
                    call site_wise_rtrans(p_2d,nbands,-1)
                    p_2d=transpose(p_2d)
                enddo
            enddo
        enddo
    enddo
    nullify(p_2d)
    return

    end subroutine rotate_bare_hamiltonian

    subroutine site_wise_rtrans(a,n,mode)
    integer,intent(in)::n,mode
    complex(q),intent(inout)::a(n,n)

    integer nbase,i,naso
    complex(q),pointer::p_trans(:,:)
    complex(q),target::utrans(wh%nasomax**2)

    nbase=0
    do i=1,wh%num_imp
        naso=wh%co(i)%dimso
        p_trans(1:naso,1:naso) => utrans(1:naso**2)
        if(wh%iso==1)then
            p_trans=wh%co(i)%db2sab(1:naso,1::2)
        else
            p_trans = wh%co(i)%db2sab
        endif
        if(mode<0)then
            p_trans=conjg(p_trans)
        endif
        call anmxbmm("n",a(:,nbase+1:nbase+naso), &
                &p_trans,n,naso)
        nbase=nbase+naso
    enddo
    nullify(p_trans)
    return

    end subroutine site_wise_rtrans

    subroutine rotate_h1e_list()
    integer i,na2,na
    complex(q),pointer::p_h1e(:,:)
    complex(q),target::h1e(wh%na2max**2)

    ! check if necessary
    if(.not.associated(wh%db2sab))return

    do i=1,wh%num_imp
        na2=wh%co(i)%dim2; na=wh%co(i)%dim
        if(wh%iso==1.and.(.not.associated(wh%db2sab)))then
            ! {{orbs}_up, {orbs}_dn} -> {{orb_up, orb_dn}}
            p_h1e(1:na2,1:na2) => h1e(1:na2**2)
            p_h1e=wh%co(i)%h1e
            wh%co(i)%h1e(1::2,1::2)=p_h1e(1:na,1:na)
            wh%co(i)%h1e(2::2,2::2)=p_h1e(1+na:,1+na:)
            wh%co(i)%h1e(1::2,2::2)=0
            wh%co(i)%h1e(2::2,1::2)=0
        else
            call uhau(wh%co(i)%h1e,wh%co(i)%db2sab,na2,na2)
        endif
    enddo
    nullify(p_h1e)
    return

    end subroutine rotate_h1e_list

    subroutine rm_h1e_from_bare_hamiltonian()
    integer i,ivec,isym,ikp,iks,ikpl,isp
    integer naso,nstep,nbase,nasot,nbands
    complex(q) h1e(wh%nasotot,wh%nasotot,bnd%nspin_in)
    complex(q),pointer::p_hk0(:,:)

    h1e=0
    nbase=1
    do i=1,wh%num_imp
        naso=wh%co(i)%dimso
        nstep=wh%co(i)%dim2/naso
        do isp=1,bnd%nspin_in
            h1e(nbase:nbase+naso-1,nbase:nbase+naso-1,isp)= &
                    &wh%co(i)%h1e(isp::nstep,isp::nstep)
        enddo
        nbase=nbase+naso
    enddo
    nasot=wh%nasotot

    ikpl=0
    do ivec=1,gp%nvec
        do iks=1,gp%kvec(ivec,2)
            ikp=gp%kvec(ivec,3)+iks
            if(gp%ipar==1)then
                ikpl=ikp
            else
                ikpl=ikpl+1
            endif
            do isp=1,bnd%nspin_in
                nbands=bnd%ne(3,ikp,isp)-bnd%ne(2,ikp,isp)+1
                do isym=1,sym%nop
                    p_hk0(1:nbands,1:nbands)=>bnd%hk0(1:nbands**2, &
                            &isym,ikpl,isp)
                    p_hk0(1:nasot,1:nasot)=p_hk0(1:nasot,1:nasot)-h1e(:,:,isp)
                enddo
            enddo
        enddo
    enddo
    nullify(p_hk0)
    return

    end subroutine rm_h1e_from_bare_hamiltonian

    !*************************************************************************
    !< calc band energy
    !*************************************************************************
    subroutine calc_ebnd()
    integer ikp,ikpl,iks,ivec,isp,ispp,nemin,nemax,nbands,i,j
    complex(q),pointer::p_a(:,:),p_v(:,:),p_psi0b(:,:)
    complex(q),target::a(bnd%nmaxin**2)

    if(wh%ispin/=2.or.wh%iso/=2)then
        bnd%eband=bnd%ets2
        do ikp=1,kpt%dim
            do isp=1,wh%nspin
                ispp=min(isp,bnd%nspin_in)
                bnd%eband(isp)=bnd%eband(isp)+ &
                        &sum(bnd%ek(:,ikp,isp)*bnd%ferwe(:,ikp,isp))
            enddo
        enddo
    else
        bnd%eband=0
        ikpl=0
        do ivec=1,gp%nvec
            do iks=1,gp%kvec(ivec,2)
                ikp=gp%kvec(ivec,3)+iks
                if(gp%ipar==1)then
                    ikpl=ikp
                else
                    ikpl=ikpl+1
                endif
                do isp=1,2
                    nemin=bnd%ne(2,ikp,1)
                    nemax=bnd%ne(3,ikp,1)
                    if(nemin>1)then
                        bnd%eband(isp)=bnd%eband(isp)+sum(&
                                &bnd%ek(:nemin-1,ikp,1)* &
                                &bnd%ferwe(:nemin-1,ikp,1)* &
                                &bnd%normso(:nemin-1,isp,ikp))
                    endif
                    nbands=nemax-nemin+1
                    p_a(1:nbands,1:nbands)=>a(1:nbands**2)
                    p_psi0b(1:nbands,1:nbands)=>bnd%psi0_b(1:nbands**2,ikpl,1)
                    p_v(1:nbands,1:nbands)=>bnd%vk(1:nbands**2,sym%ie,ikpl,1)
                    call zgemm('n','n',nbands,nbands,nbands,z1,p_psi0b, &
                            &nbands,p_v,nbands,z0,p_a,nbands)
                    do i=1,nbands; do j=1,nbands
                        bnd%eband(isp)=bnd%eband(isp)+ &
                                &bnd%ek(nemin-1+i,ikp,1)*p_a(i,j)* &
                                &conjg(p_a(i,j))*bnd%ferwe(nemin-1+i,ikp,1)* &
                                &bnd%normso(nemin-1+j,isp,ikp)
                    enddo; enddo
                enddo
            enddo
        enddo
#ifdef mpi_mode
        call sum_all_mpi(bnd%eband,2)
#endif
        bnd%eband=bnd%eband+bnd%ets2/2
        nullify(p_a,p_v,p_psi0b)
    endif
    return

    end subroutine calc_ebnd

    subroutine calc_e_hybrd()

    bnd%ehybrd=real(sum(wh%r*(wh%d0)),q)
    return

    end subroutine calc_e_hybrd

    !*************************************************************************
    !< check magnetic moment for the case of spin-polarized calculations.
    !*************************************************************************
    subroutine chk_mag_moment(io)
    integer,intent(in)::io

    integer isp,ikp
    real(q) nel(2)

    if(io<0)return
    if(wh%nspin==1.or.wh%iso==2)return
    nel=0
    do isp=1,wh%nspin
        do ikp=1,kpt%dim
            nel(isp) = nel(isp) + sum(bnd%ferwe(:,ikp,isp))*kpt%wt(ikp)
        enddo
    enddo
    write(io,'(" total (quasi-particle) magnetic moment = ", f12.4)') &
            &nel(2)- nel(1)
    return

    end subroutine chk_mag_moment

    !*************************************************************************
    !> f_n <psi_n|a> r_{a,A} r^+_{B,b} <b|psi_n>
    !! =r^+_{B,b} <b|psi_n> f_n <psi_n|a> r_{a,A}
    !*************************************************************************
    subroutine calc_nabr_1k(nabr,vk,ferwe,nbands,wtk,wtk0,isp)
    integer,intent(in)       :: nbands,isp
    real(q),intent(in)       :: wtk,wtk0,ferwe(nbands)
    complex(q),intent(in)    :: vk(nbands,nbands)
    complex(q),intent(inout) :: nabr(nbands,nbands)

    integer ia,nasot
    complex(q) r(wh%nasotot,wh%nasotot)

    !< r^+_{B,b}<b|psi>f<psi|a>
    call calc_nabr1_1k(nabr,vk,ferwe,nbands,wtk,isp)
    nasot=wh%nasotot
    r=bnd%r(:,:,isp)
    !< r^+_{B,b}<b|psi>f<psi|a>r(a,A)
    call anmxbmm('n',nabr(:,1:nasot),r,nbands,nasot)
    nabr=transpose(nabr) ! to {A,B}
    nabr(1:nasot,1:nasot)=nabr(1:nasot,1:nasot)+ &
            &(-bnd%nrl(:,:,isp)+bnd%nc_phy(:,:,isp))*wtk0
    return

    end subroutine calc_nabr_1k

    !*************************************************************************
    !> r^+ applied to right side only, for d
    !! r^+ <b|psi>f<psi|a>.
    !*************************************************************************
    subroutine calc_nabr1_1k(nabr,vk,ferwe,nbands,wtk,isp)
    integer,intent(in)       :: nbands,isp
    real(q),intent(in)       :: wtk,ferwe(nbands)
    complex(q),intent(in)    :: vk(nbands,nbands)
    complex(q),intent(out) :: nabr(nbands,nbands)

    integer nasot
    complex(q) zr(wh%nasotot,wh%nasotot),nabr_sub(wh%nasotot,nbands)

    call calc_nab_1k(nabr,vk,ferwe,nbands,nbands,wtk)
    nasot=wh%nasotot
    zr=bnd%r(:,:,isp)
    nabr_sub=nabr(1:nasot,:)
    ! r^+ <b|psi>f<psi|a>
    call annxb('c',zr,nabr_sub,nasot,nbands,nabr(1:nasot,:))
    return

    end subroutine calc_nabr1_1k

    !*************************************************************************
    !D0^{t}_{A,a}
    != f_n <psi_n|a> h_{A,B} r^+_{B,b} <b|psi_n>
    != h_{A,B} r^+_{B,b} <b|psi_n> f_n <psi_n|a>
    !*************************************************************************
    subroutine add_da_1k(hk0,vk,ferwe,nbands,wtk,isp)
    integer,intent(in)    :: nbands,isp
    real(q),intent(in)    :: wtk,ferwe(nbands)
    complex(q),intent(in) :: hk0(nbands,nbands),vk(nbands,nbands)

    complex(q) nabr(nbands,nbands),zd(wh%nasotot,wh%nasotot), &
            &hk0_(wh%nasotot,nbands)

    call calc_nabr1_1k(nabr,vk,ferwe,nbands,wtk,isp) ! r^+ <b|psi>f<psi|a>
    hk0_=hk0(1:wh%nasotot,:)
    call zgemm('n','n',wh%nasotot,wh%nasotot,nbands,z1, &
            &hk0_,wh%nasotot,nabr(:,1:wh%nasotot),nbands,z0,zd,wh%nasotot)
    ! D0 can be real or complex type .
    bnd%d0(:,:,isp)=bnd%d0(:,:,isp)+zd
    return

    end subroutine add_da_1k

    !< calculate n_{ab} at a single k-point.
    subroutine calc_nab_1k(nab,vk,ferwe,nbasis,nbands,wtk)
    integer,intent(in)     :: nbasis,nbands
    real(q),intent(in)     :: wtk,ferwe(nbands)
    complex(q),intent(in)  :: vk(nbasis,nbands)
    complex(q),intent(out) :: nab(nbasis,nbasis)

    integer ib
    complex(q) vf(nbasis,nbands)

    do ib=1,nbands
        vf(:,ib)=vk(:,ib)*ferwe(ib)*wtk
    enddo
    call zgemm('n','c',nbasis,nbasis,nbands,z1,vf,nbasis,vk,nbasis,z0, &
            &nab,nbasis) ! <b|psi>f<psi|a>
    return

    end subroutine calc_nab_1k

    subroutine calc_da0()
    integer isym,ivec,iks,ikp,ikpl,isp,ispp,nbands,nemin,nemax
    real(q) wtk
    complex(q),pointer :: p_vk(:,:),p_hk0(:,:)
    real(q),pointer :: ferwe(:)

    bnd%d0=0
    wtk=1._q/sym%nop/wh%rspo
    ikpl=0
    do ivec=1,gp%nvec
        do iks=1,gp%kvec(ivec,2)
            ikp=gp%kvec(ivec,3)+iks
            if(gp%ipar==1)then
                ikpl=ikp
            else
                ikpl=ikpl+1
            endif
            do isp=1,wh%nspin
                ispp=min(isp,bnd%nspin_in)
                nemin=bnd%ne(2,ikp,ispp)
                nemax=bnd%ne(3,ikp,ispp)
                nbands=nemax-nemin+1
                ferwe=>bnd%ferwe(nemin:nemax,ikp,isp)
                do isym=1,sym%nop
                    p_hk0(1:nbands,1:nbands)=>bnd%hk0(1:nbands**2, &
                            &isym,ikpl,ispp)
                    p_vk(1:nbands,1:nbands)=>bnd%vk(1:nbands**2,isym,ikpl,isp)
                    call add_da_1k(p_hk0,p_vk,ferwe,nbands,wtk,isp)
                enddo
            enddo
        enddo
    enddo
#ifdef mpi_mode
    call zsum_all_mpi(bnd%d0,wh%nasotot*wh%nasotot*wh%nspin)
#endif
    nullify(p_vk,p_hk0,ferwe)

    ! back to D0_{a,A}
    do isp=1,wh%nspin
        bnd%d0(:,:,isp)=transpose(bnd%d0(:,:,isp))
    enddo
    call map_wh_bnd_matrix(wh%d0,bnd%d0,.true.)
    return

    end subroutine calc_da0

    subroutine calc_nks()
    integer ikpl,ivec,iks,ikp,isym,isp,ispp,nbands,nbase,&
            &n1,n2,i,naso,nemin,nemax
    real(q) wtk
    real(q),pointer :: p_ferwe(:)
    complex(q),pointer :: p_vk(:,:),p_vk_sub(:,:),p_nks(:,:)
    complex(q),target::nks(wh%nasomax*wh%nasomax)
    complex(q),target::vk_sub(wh%nasomax*bnd%nmaxin)

    complex(q) tmp(bnd%nmaxin,bnd%nmaxin)

    wh%nks=0
    wtk=1._q/sym%nop/wh%rspo
    ikpl=0
    do ivec=1,gp%nvec
        do iks=1,gp%kvec(ivec,2)
            ikp=gp%kvec(ivec,3)+iks
            if(gp%ipar==1)then
                ikpl=ikp
            else
                ikpl=ikpl+1
            endif
            do isp=1,wh%nspin
                ispp=min(isp,bnd%nspin_in)
                nemin=bnd%ne(2,ikp,ispp)
                nemax=bnd%ne(3,ikp,ispp)
                nbands=nemax-nemin+1
                p_ferwe=>bnd%ferwe(nemin:nemax,ikp,isp)
                do isym=1,sym%nop
                    p_vk(1:nbands,1:nbands)=>bnd%vk(1:nbands**2,isym,ikpl,isp)
                    nbase=0
                    do i=1,wh%num_imp
                        naso=wh%co(i)%dimso
                        n1=1+(isp-1)*naso; n2=naso*isp
                        p_vk_sub(1:naso,1:nbands)=>vk_sub(1:naso*nbands)
                        p_vk_sub=p_vk(nbase+1:nbase+naso,1:nbands)
                        p_nks(1:naso,1:naso)=>nks(1:naso*naso)
                        call calc_nab_1k(p_nks,p_vk_sub,p_ferwe,naso, &
                                &nbands,wtk)
                        wh%co(i)%nks(n1:n2,n1:n2)=wh%co(i)%nks(n1:n2,n1:n2) +&
                                &transpose(p_nks)
                        nbase=nbase+naso
                    enddo
                enddo
            enddo
        enddo
    enddo
    nullify(p_ferwe,p_vk,p_vk_sub,p_nks)
#ifdef mpi_mode
    call sum_all_mpi(wh%nks,wh%na2112)
#endif
    do i=1,wh%num_imp
        call co_nks_patch_order(wh%co(i),wh%ispo,wh%iso)
    enddo
    return

    end subroutine calc_nks

    !*************************************************************************
    !> f_n <psi_n|a> r_{a,A} r^+_{B,b} <b|psi_n>
    !! =r^+_{B,b} <b|psi_n> f_n <psi_n|a> r_{a,A}
    !*************************************************************************
    subroutine calc_rnrl()
    integer isp,n

    n=wh%nasotot
    do isp=1,wh%nspin
        !< <b|psi_n> f_n <psi_n|a> r_{a,A}
        call zgemm('t','n',n,n,n,z1,bnd%nks(:,:,isp),n,bnd%r(:,:,isp),n, &
                &z0,bnd%nrl(:,:,isp),n)
        !< r^+_{B,b}<b|psi_n> f_n <psi_n|a> r_{a,A}
        call annxb('c',bnd%r(:,:,isp),bnd%nrl(:,:,isp),n,n)
        !< bring back to {A,B}
        bnd%nrl(:,:,isp)=transpose(bnd%nrl(:,:,isp))
    enddo
    return

    end subroutine calc_rnrl

    subroutine map_wh_bnd_matrix(x,y,lback)
    complex(q) x(wh%na2112),y(wh%nasotot,wh%nasotot,wh%nspin)
    logical,intent(in)::lback

    integer i,isp
    integer na2,naso,nbase,ibase
    complex(q),target::buf(wh%na2max**2)
    complex(q),pointer::p_buf(:,:)

    nbase=0
    ibase=0
    do i=1,wh%num_imp
        na2=wh%co(i)%dim2
        naso=wh%co(i)%dimso
        p_buf(1:na2,1:na2)=>buf(1:na2**2)
        if(.not.lback)then
            buf(1:na2**2)=x(ibase+1:ibase+na2*na2)
            if(wh%iso==1)call orbital_spin_trans(p_buf,na2,.false.)
            do isp=1,wh%nspin
                y(nbase+1:nbase+naso,nbase+1:nbase+naso,isp)= &
                        &p_buf((isp-1)*naso+1:isp*naso,(isp-1)*naso+1:isp*naso)
            enddo
        else
            buf=0
            do isp=1,wh%nspin
                p_buf((isp-1)*naso+1:isp*naso,(isp-1)*naso+1:isp*naso)= &
                        &y(nbase+1:nbase+naso,nbase+1:nbase+naso,isp)
            enddo
            if(wh%ispo==1)p_buf(1+naso:na2,1+naso:na2)=p_buf(1:naso,1:naso)
            if(wh%iso==1)call orbital_spin_trans(p_buf,na2,.true.)
            x(ibase+1:ibase+na2*na2)=buf(1:na2**2)
        endif
        nbase=nbase+naso
        ibase=ibase+na2*na2
    enddo
    return

    end subroutine map_wh_bnd_matrix

    !*************************************************************************
    subroutine calc_band_all(io)
    integer,intent(in)::io

    integer isym,ivec,iks,ikp,ikpl,nbands,isp,ispp
    complex(q),pointer :: hk(:,:)
    real(q),pointer :: ek_list(:,:,:)
    complex(q) :: r(wh%nasotot,wh%nasotot),la1(wh%nasotot,wh%nasotot)

    call set_time_point(1,2)

#ifdef mpi_mode
    allocate(ek_list(bnd%nmax,kpt%dim,wh%nspin))
    ek_list=0
#else
    ek_list=>bnd%ek
#endif

    ikpl=0
    !$omp parallel do &
    !$omp &firstprivate(ikpl) &
    !$omp &private(ivec,isym,isp,ispp,iks,ikp,nbands,hk,r,la1) &
    !$omp &schedule(static,1)
    do ivec=1,gp%nvec
        do iks=1,gp%kvec(ivec,2)
            ikp=gp%kvec(ivec,3)+iks
            if(gp%ipar==1)then
                ikpl=ikp
            else
                ikpl=ikpl+1
            endif
            do isym=1,sym%nop
                do isp=1,wh%nspin
                    ispp=min(isp,bnd%nspin_in)
                    nbands=bnd%ne(3,ikp,ispp)-bnd%ne(2,ikp,ispp)+1
                    hk(1:nbands,1:nbands)=>bnd%vk(1:nbands**2,isym,ikpl,isp)
                    r=bnd%r(:,:,isp)
                    la1=bnd%la1(:,:,isp)
                    bnd%vk(1:nbands**2,isym,ikpl,isp)=&
                            &bnd%hk0(1:nbands**2,isym,ikpl,ispp)
                    if(isym==1)then
                        ! save the energies outside of the energy window.
#ifdef mpi_mode
                        ek_list(:,ikp,isp)=bnd%ek(:,ikp,isp)
#endif
                        call calc_band_1k(hk,r,la1,nbands,wh%nasotot, &
                                &ek_list(bnd%ne(2,ikp,ispp): &
                                &bnd%ne(3,ikp,ispp),ikp,isp))
                    else
                        call calc_band_1k(hk,r,la1,nbands,wh%nasotot)
                    endif
                enddo
            enddo !isym
        enddo ! iks
    enddo ! ivec
    !$omp end parallel do
    nullify(hk)

#ifdef mpi_mode
    call dsum_all_mpi(ek_list,bnd%nmax*kpt%dim*wh%nspin)
    bnd%ek=ek_list
    deallocate(ek_list)
#endif
    nullify(ek_list)

    call set_time_point(2,2)
    call print_time_usage('calc_band_all',2,io)
    return

    end subroutine calc_band_all

    !*************************************************************************
    subroutine calc_band_1k(hk,r,la1,nbands,nasot,ek)
    integer,intent(in)::nbands,nasot
    complex(q),intent(in)::r(nasot,nasot),la1(nasot,nasot)
    complex(q),intent(inout)::hk(nbands,nbands)
    real(q),optional,intent(out)::ek(nbands)

    real(q) w(nbands)

    call calc_hamil_1k(hk,r,la1,nbands,nasot)
    call hermev('v','u',hk,w,nbands)
    if(present(ek))then
        ek=w
    endif
    return

    end subroutine calc_band_1k

    ! Here bnd%hk0 will be replaced by the renormalized occupation matrix
    ! of the bare Kohn-Sham bands.
    subroutine calc_kswt(io)
    integer,intent(in)::io

    integer ivec,iks,ikp,ikpl,nbands,isp,i,ispp,nsp,naso,nbase
    real(q) sumwt(2),maxoffdiag,fac_irspo
    complex(q),pointer :: p_vk(:,:),p_kswt(:,:),p_uk(:,:),p_utrans(:,:)
    complex(q),target::utrans(wh%nasomax**2)
    real(q),pointer :: p_ferwe(:)

    call set_time_point(1,2)
    sumwt=0
    maxoffdiag=0
    ikpl=0
    fac_irspo=1._q/wh%rspo

    !$omp parallel do &
    !$omp &firstprivate(ikpl) &
    !$omp &private(ivec,isp,ispp,iks,ikp,i,nbands,nbase,nsp, &
    !$omp         &p_kswt,p_ferwe,p_vk,p_uk,utrans,p_utrans, &
    !$omp         &naso,f_id) &
    !$omp &schedule(static,1) &
    !$omp &reduction(+:sumwt) &
    !$omp &reduction(max:maxoffdiag)
    do ivec=1,gp%nvec
        do iks=1,gp%kvec(ivec,2)
            ikp=gp%kvec(ivec,3)+iks
            if(gp%ipar==1)then
                ikpl=ikp
            else
                ikpl=ikpl+1
            endif
            do ispp=1,bnd%nspin_in
                if(bnd%nspin_in==1)then
                    nsp=wh%nspin
                else
                    nsp=ispp
                endif
                nbands=bnd%ne(3,ikp,ispp)-bnd%ne(2,ikp,ispp)+1
                ! do not need hk0 anymore, store kswt instead.
                p_kswt(1:nbands,1:nbands)=>bnd%hk0(1:nbands**2,sym%ie, &
                        &ikpl,ispp)
                p_kswt=0
                p_uk(1:nbands,1:nbands)=>bnd%psi0_b(1:nbands**2,ikpl,ispp)
                do isp=ispp,nsp
                    p_ferwe=>bnd%ferwe(bnd%ne(2,ikp,ispp): &
                            &bnd%ne(3,ikp,ispp),ikp,isp)
                    p_vk(1:nbands,1:nbands)=>bnd%vk(1:nbands**2,sym%ie,&
                            &ikpl,isp)
                    call calc_kswt_1k(p_kswt,p_vk,p_uk,p_ferwe,nbands, &
                            &fac_irspo,kpt%wt(ikp),isp)
                    sumwt(1)=sumwt(1)+sum(p_ferwe)
                enddo ! isp
                p_kswt=p_kswt*wh%rspo

                do i=1,nbands
                    sumwt(2)=sumwt(2)+real(p_kswt(i,i),q)
                    if(i==nbands)exit
                    maxoffdiag=max(maxoffdiag, &
                            &maxval(abs(p_kswt(i+1:,i)))/kpt%wt(ikp))
                enddo
            enddo
        enddo ! iks
    enddo ! ivec
    !$omp end parallel do
    nullify(p_vk,p_uk,p_ferwe,p_kswt,p_utrans)

#ifdef mpi_mode
    call gmpi_barrier()
    call sum_all_mpi(sumwt,2)
    call max_all_mpi(maxoffdiag)
#endif

    if(io>0)then
        write(io,'(" correlated subspace, sum_ferwt = ",f0.7, &
                &" sum_kswt = ",f0.7)')sumwt
        write(io,'("     max off diagonal of psik occ. mat. = ", &
                &f0.6)')maxoffdiag
        sumwt(1) = sumwt(1)-sumwt(2)
        if(abs(sumwt(1))>1.e-4_q)then
            write(0,'(" warning: too large sum_ferwt-sum_kswt = ", &
                    &f0.5,"!")')sumwt(1)
            write(io,'(" warning: too large sum_ferwt-sum_kswt = ", &
                    &f0.5,"!")')sumwt(1)
        endif
    endif

    call set_time_point(2,2)
    call print_time_usage('calc_kswt',2,io)
    return

    end subroutine calc_kswt

    !*************************************************************************
    subroutine calc_kswt_1k(kswt,vk,uk,ferwe,nbands,wtk,wtk0,isp)
    integer,intent(in)::nbands,isp
    real(q),intent(in)::ferwe(nbands),wtk,wtk0
    complex(q),intent(in)::vk(nbands,nbands),uk(nbands,nbands)
    complex(q),intent(inout)::kswt(nbands,nbands)

    complex(q) nabr(nbands,nbands)

    call calc_nabr_1k(nabr,vk,ferwe,nbands,wtk,wtk0,isp) ! ~ f<psi|a><b|psi>
    nabr=transpose(nabr) ! ~ form <a|psi>f<psi|b>
    call uhau(nabr,uk,nbands,nbands,trul='n',trur='c')
    kswt=kswt+nabr ! density matrix <a|psi>f_psi<psi|b>
    return

    end subroutine calc_kswt_1k

    !*************************************************************************
    subroutine calc_hamil_1k(hk,r,la1,nbands,nasot)
    integer,intent(in)::nbands,nasot
    complex(q),intent(in)::r(nasot,nasot),la1(nasot,nasot)
    complex(q),intent(inout)::hk(nbands,nbands)

    integer ia
    complex(q) hk_sub(nasot,nbands)

    hk_sub = hk(1:nasot,:)
    call annxb('n',r,hk_sub,nasot,nbands,hk(1:nasot,:))
    call anmxbmm('c',hk(:,1:nasot),r,nbands,nasot) ! rhr^+
    hk(1:nasot,1:nasot)=hk(1:nasot,1:nasot)+la1
    return

    end subroutine calc_hamil_1k

    !*************************************************************************
    !< calc total magnetic moment
    !*************************************************************************
    subroutine calc_mup_dn(io)
    integer,intent(in)::io

    integer ik

    if(wh%nspin==1)return
    bnd%mup_dn=0
    do ik=1,kpt%dim
        bnd%mup_dn=bnd%mup_dn+sum(bnd%ferwe(:,ik,1)-bnd%ferwe(:,ik,2))
    enddo
    if(io>0)then
        write(io,'(" total magnetic moment: ",f8.3)')bnd%mup_dn
    endif
    return

    end subroutine calc_mup_dn

    subroutine calc_corr_ebwidth(io)
    integer,intent(in)::io

    integer ik,isp
    real(q) emin,emax

    if(io<0)return
    emin=100._q; emax=-100._q
    do ik=1,kpt%dim
        do isp=1,bnd%nspin_in
            emin=min(emin,bnd%ek(bnd%ne(2,ik,isp),ik,isp))
            emax=max(emax,bnd%ek(bnd%ne(3,ik,isp),ik,isp))
        enddo
    enddo
    write(io,'(" correlated block: emin/emix=",2f10.4)')emin,emax
    bnd%ebmin=emin; bnd%ebmax=emax
    bnd%ebwidth=emax-emin
    return

    end subroutine calc_corr_ebwidth

    subroutine set_kpt_icor(io)
    integer,intent(in)::io

    if(kpt%ismear/=-5)return
    kpt%icor=1
    if(abs(kpt%delta)>100._q)kpt%icor=0
    kpt%cordeg=-1.d-6
    if(kpt%delta>100._q)then
        kpt%cordeg=-kpt%delta+100._q
    elseif(kpt%delta>0._q)then
        kpt%cordeg=-kpt%delta
    elseif(kpt%delta<-100._q)then
        kpt%cordeg= kpt%delta-100._q
    elseif(kpt%delta<0._q)then
        kpt%cordeg= kpt%delta
    endif
    if(abs(kpt%cordeg)>.01_q)kpt%cordeg=-1.d-6
    if(io>0)write(io,'(" bz integration with tetra method, icor=",i2)')&
            &kpt%icor
    if(kpt%cordeg<0._q.and.io>0)write(io,'(" equal occupancy of degenerate &
        &states, tol=",e8.1)')-kpt%cordeg
    return

    end subroutine set_kpt_icor

    !*************************************************************************
    subroutine gutz_fermi(io)
    integer,intent(in)::io

    if(kpt%ismear==-5)then
        call gutz_fermi_tetra_w2k()
    elseif(kpt%ismear==0.or.kpt%ismear==-1)then
        call get_ef_fun()
    else
        write(0,'(" ismear=",i2)')kpt%ismear
        stop ' error: unsupported ismear!'
    endif
    call adjust_efermi_bandgap(io)
    if(io>0)write(io,'(" gutz fermi level=",f16.8)')bnd%ef
    return

    end subroutine gutz_fermi

    subroutine adjust_efermi_bandgap(io)
    integer,intent(in)::io

    integer ihomo,i
    real(q) ecmin,evmax

    ! check band gap
    ihomo=0
    do i=1,bnd%ne(3,1,1)
        if(bnd%ek(i,1,1)<bnd%ef)then
            ihomo=i
        else
            exit
        endif
    enddo
    ! conduction band minimum
    ecmin=minval(bnd%ek(ihomo+1,:,:))
    ! valence band maximum
    evmax=maxval(bnd%ek(ihomo,:,:))
    if(evmax<bnd%ef.and.ecmin>bnd%ef)then
        if(io>0)write(io,'(" band gap identified!")')
        bnd%ef=(evmax+ecmin)/2
    endif
    return

    end subroutine adjust_efermi_bandgap

    !*************************************************************************
    subroutine gutz_fermi_tetra_w2k()
    integer,parameter::nw=250000
    integer :: iw(nw)
    real(q),allocatable::eb(:,:,:),e_(:,:),weight_(:)
    integer,allocatable::nehelp(:,:)
    real(q)elecn,ef
    integer nkpt,nemax,jspin,iso,nbmax
    integer ik,isp,ispp,n1,n2

    nkpt=kpt%dim; nemax=bnd%nmax; iso=wh%iso
    allocate(nehelp(nkpt,2),eb(nemax,nkpt,2))
    eb=3._q
    do isp=1,2
        ispp=min(isp,bnd%nspin_in)
        nehelp(:,isp)=bnd%ne(1,:,ispp)
        ispp=min(isp,wh%nspin)
        do ik=1,nkpt
            eb(1:nehelp(ik,isp),ik,isp)=bnd%ek(1:nehelp(ik,isp),ik,ispp)
        enddo
    enddo
    elecn=bnd%nelet-1.d-10-bnd%nelet_frozen
    jspin=wh%ispin
    allocate(e_(nemax*jspin,nkpt)); e_=0
    e_(1:nemax,:) = eb(:,:,1)
    if(jspin==2)then
        e_(1+nemax:,:) = eb(:,:,2)
    endif

    allocate(weight_(nemax*jspin*nkpt)); weight_=0
    open(iu_kgen,file=kpt%file_name,status='old')
    ! consistent check
    read(iu_kgen,*)n1
    rewind(iu_kgen)
    if(n1/=nkpt)then
        bnd%ef=0
        return
    endif
    call dos(nemax*jspin,nkpt,e_,weight_,elecn/2.d0*iso*jspin,ef,iw,nw)
    call eweigh(ef,weight_,nemax,nkpt,jspin,nehelp,eb,nbmax)
    close(iu_kgen)
    do isp=1,wh%nspin
        do ik=1,nkpt
            n1=(ik-1)*nemax*jspin+(isp-1)*nemax+1
            n2=(ik-1)*nemax*jspin+ isp   *nemax
            bnd%ferwe(:,ik,isp)=weight_(n1:n2)*wh%rspo  ! convention
        enddo
    enddo
    bnd%ets2=0; bnd%ef=ef
    deallocate(eb,e_,weight_,nehelp)
    return

    end subroutine gutz_fermi_tetra_w2k

    !*************************************************************************
    subroutine bnd_modify_frozen()
    integer ik,i,isp,ispp,ntop

    if(bnd%n_frozen==0)return
    do ik=1,kpt%dim
        do isp=1,wh%nspin
            ispp=min(isp,bnd%nspin_in)
            ntop=bnd%ne(3,ik,ispp)
            do i=ntop-bnd%n_frozen*wh%iso/2+1,ntop
                if(abs(bnd%ek(i,ik,isp)-30._q)>1.e-6_q)then
                    write(0,'(" fetal error in bnd_modify_frozen (!=30): &
                            &fixed band level = ",2f12.4)')bnd%ek(i,ik,isp)
                    stop
                endif
                bnd%ek(i,ik,isp)=bnd%ef
                bnd%ferwe(i,ik,isp)=real(bnd%nelet_frozen,q)/bnd%n_frozen* &
                        &wh%rspo*kpt%wt(ik)
            enddo
        enddo
    enddo
    return

    end subroutine bnd_modify_frozen

    subroutine set_fermi_weight(mu)
    implicit none
    real(q) mu

    integer isp,ispp,ikp,ib
    real(q) dt

    bnd%ferwe=0
    do isp=1,wh%nspin
        ispp=min(isp,bnd%nspin_in)
        do ikp=1,kpt%dim
            do ib=1,bnd%ne(1,ikp,ispp)
                dt=(bnd%ek(ib,ikp,isp)-mu)/kpt%delta
                select case(kpt%ismear)
                case(-1)
                    bnd%ferwe(ib,ikp,isp)=fermi_fun(dt)
                case(0)
                    bnd%ferwe(ib,ikp,isp)=gauss_fun(dt)
                case default
                    stop ' error in nelect_fun: kpt%ismear not supported!'
                end select
                bnd%ferwe(ib,ikp,isp)=bnd%ferwe(ib,ikp,isp)*wh%rspo*kpt%wt(ikp)
            enddo
        enddo
    enddo
    return

    end subroutine set_fermi_weight

end module bandstru

!*****************************************************************************
subroutine get_ef_fun()
    use gprec
    use bandstru
    implicit none
    real(q) emin,emax
    real(q),parameter::eps=1.e-10_q
    real(q),external::rtbis,dif_nele_fun

    if(kpt%ensemble==0)then ! Canonical ensemble
        bnd%ferwe=0
        if(abs(bnd%nelet-bnd%nelet_frozen)<1.e-6_q)then
            bnd%ef=0; return
        endif
        emin=minval(bnd%ek); emax=maxval(bnd%ek)
        bnd%ef=rtbis(dif_nele_fun,emin,emax,eps)
    else
        call set_fermi_weight(bnd%ef)
    endif

    select case(kpt%ismear)
    case(-1)
        call calc_entropy_fermi()
    case(0)
        call calc_correction_gauss()
    end select
    return

end subroutine get_ef_fun

!*****************************************************************************
subroutine calc_correction_gauss()
    use gprec
    use gconstant
    use bandstru
    implicit none
    integer ikp,isp,ispp,ib
    real(q) eta,de

    bnd%ets2=0
    do isp=1,wh%nspin
        eta=0
        ispp=min(isp,bnd%nspin_in)
        do ikp=1,kpt%dim
            do ib=1,bnd%ne(1,ikp,ispp)
                de=(bnd%ek(ib,ikp,isp)-bnd%ef)/kpt%delta
                de=de*de
                if(de<15._q)eta=eta+0.5*kpt%delta*exp(-de)*kpt%wt(ikp)*wh%rspo
            enddo
        enddo
        eta=-eta*2._q/sqrt(pi)
        bnd%ets2(isp)=eta/2._q
    enddo
    return

end subroutine calc_correction_gauss

!*****************************************************************************
subroutine calc_entropy_fermi()
    use gprec
    use gconstant
    use bandstru
    implicit none
    integer ikp,isp,ispp,ib
    real(q) entr,focc,f1,f2,eint

    bnd%ets2=0
    do isp=1,wh%nspin
        entr=0
        ispp=min(isp,bnd%ispin_in)
        do ikp=1,kpt%dim
            do ib=1,bnd%ne(1,ikp,ispp)
                focc=bnd%ferwe(ib,ikp,isp)/wh%rspo/kpt%wt(ikp)
                f1=focc; f2=1._q-focc
                if(f1>0._q.and.f2>0._q)then
                    eint=f1*log(f1)+f2*log(f2)
                    entr=entr+eint*kpt%wt(ikp)*wh%rspo
                endif
            enddo
        enddo
        bnd%ets2(isp)=kpt%delta*entr
    enddo
    return

end subroutine calc_entropy_fermi

!*****************************************************************************
function dif_nele_fun(mu)
    use gprec
    use bandstru
    use gutil
    implicit none
    real(q) mu,dif_nele_fun

    real(q) nelet

    call set_fermi_weight(mu)
    nelet=sum(bnd%ferwe)
    dif_nele_fun=nelet-(bnd%nelet-bnd%nelet_frozen)
    return

end function dif_nele_fun

!*****************************************************************************
function rtbis(func,x1,x2,tol)
    use gprec
    implicit none
    real(q) x1,x2,tol,dx,xmid,fmid,f,rtbis
    integer j
    integer,parameter::jmax=500
    real(q),external::func

    fmid=func(x2)
    f=func(x1)
    if(f*fmid.ge.0._q) goto 900
    if(f.lt.0.)then
        rtbis=x1
        dx=x2-x1
    else
        rtbis=x2
        dx=x1-x2
    endif
    do j=1,jmax
        dx=dx*.5_q
        xmid=rtbis+dx
        fmid=func(xmid)
        if(fmid.le.0._q)rtbis=xmid
        if(abs(fmid)<tol)then
            rtbis=xmid
            return
        endif
    enddo
    goto 910
900 if(abs(fmid).lt.tol)then
        rtbis=x2
        return
    else if(abs(f).lt.tol)then
        rtbis=x1
        return
    endif
    write(0,'(" fmid and f=",2f16.8)')fmid,f
    stop ' error in rtbis: root must be bracketed for bisection.'
910 stop ' error in rtbis: too many bisections in rtbis'

end function rtbis


C
C	$Id: dashdc.f,v 1.7 2008-07-27 00:16:58 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE DASHDC (IPAT,JCRT,JSIZE)
C
C Software dashed line package with character capability
C
C PURPOSE                DASHCHAR is a software dashed line package.
C
C USAGE                  First, either
C                             CALL DASHDB (IPAT)
C                        where IPAT is a 16-bit dash pattern as
C                        described in the subroutine DASHDB (see
C                        DASHLINE documentation), or
C                             CALL DASHDC (IPAT,JCRT,JSIZE)
C                        as described below.
C
C                        Then, call any of the following:
C                             CALL CURVED (X,Y,N)
C                             CALL FRSTD (X,Y)
C                             CALL VECTD (X,Y)
C                             CALL LASTD
C
C                        LASTD is called only after the last
C                        point of a line has been processed in VECTD.
C
C                        The following may also be called, but no
C                        smoothing will result:
C                             CALL LINED (XA,YA,XB,YB)
C
C
C ARGUMENTS              IPAT
C ON INPUT                 A character string of arbitrary length
C TO DASHDC                (60 characters seems to be a practical
C                          limit) which specifies the dash pattern
C                          to be used.  A dollar sign in IPAT
C                          indicates solid; an apostrophe indicates
C                          a gap; blanks are ignored.  Any character
C                          in IPAT which is not a dollar sign,
C                          apostrophe, or blank is considered to be
C                          part of a line label.  Each line label
C                          can be at most 15 characters in length.
C                          Sufficient white space is reserved in the
C                          dashed line for writing line labels.
C
C                        JCRT
C                          The length in plotter address units per
C                          $ or apostrophe.
C
C                        JSIZE
C                          Is the size of the plotted characters:
C                          . If between 0 and 3 , it is 1., 1.5, 2.
C                            and 3. times an 8 plotter address unit
C                            width.
C                          . If greater than 3, it is the character
C                            width in plotter address units.
C
C
C ARGUMENTS TO           CURVED(X,Y,N)
C OTHER LINE-DRAWING       X and Y are arrays of world coordinate values
C ROUTINES                 of length N or greater.  Line segments obeying
C                          the specified dash pattern are drawn to
C                          connect the N points.
C
C                        FRSTD(X,Y)
C                          The current pen position is set to
C                          the world coordinate value (X,Y)
C
C                        VECTD(X,Y)
C                          A line segment is drawn between the
C                          world coordinate value (X,Y) and the
C                          most recent pen position.  (X,Y) then
C                          becomes the most recent pen position.
C
C                        LINED(XA,XB,YA,YB)
C                          A line is drawn between world coordinate
C                          values (XA,YA) and (XB,YB).
C
C                        LASTD
C                          When using FRSTD and VECTD, LASTD may be
C                          called (no arguments needed). If the dashed
C                          line package was leaving a space for characters,
C                          and the line ended before there was enough space
C                          for the characters, the space left will be
C                          filled in if LASTD is called.
C
C
C ON OUTPUT                All arguments are unchanged for all routines.
C
C
C NOTE                     When switching from the regular plotting
C                          routines to a dashed line package the first
C                          call should not be to VECTD.
C
C ENTRY POINTS             DASHDB, DASHDC, CURVED, FRSTD, VECTD, LINED,
C                          RESET, LASTD, CFVLD, DRAWPV, DASHBD, DASHBDX
C
C COMMON BLOCKS            INTPR, DASHD1, DASHD2, DDFLAG, DCFLAG, DSAVE1,
C                          DSAVE6, DSAVE3, CFFLAG, DCFLAG
C
C REQUIRED LIBRARY         The ERPRT77 package and the SPPS.
C ROUTINES
C
C REQUIRED LEVEL OF GKS    0A
C
C I/O                      Plots solid or dashed lines, possibly with
C                          characters at intervals in the line.
C
C PRECISION                Single
C
C LANGUAGE                 FORTRAN
C
C HISTORY                  Written in 1969, standardized in November 1972.
C                          Made portable in September 1977 for use
C                          with all computer systems which
C                          support plotters with up to 15 bit resolution.
C                          Converted to FORTRAN77 and GKS in May 1984.
C
C ALGORITHM                The position in the dash pattern is
C                          remembered as points are processed.  The
C                          distance transversed in plotter address space
C                          is used to determine whether to draw segments,
C                          parts of segments, characters, or nothing.
C
C ACCURACY                 Plus or minus .5 plotter address units per call.
C                          There is no cumulative error.
C
C TIMING                   For solid or blank lines, there is almost no
C                          overhead.  Dashed lines take about 4 times as
C                          long as drawing solid lines.  (The line
C                          drawing software is so fast that the increase
C                          will not be noticed in most programs.) Patterns
C                          with characters do not take much longer than
C                          those without.
C
C PORTABILITY              FORTRAN77
C
C INTERNAL PARAMETERS      NAME   DEFAULT  FUNCTION  DECLARED IN BLOCK DATA
C                          ----   -------  --------
C
C                          IPAU      3     Number of plotter addresses per
C                                          element in the dash pattern for
C                                          solid lines and gaps. The
C                                          pattern is repeated every
C                                          IPAU*16 plotter address units.
C
C                          FPART     1.    Multiplicative factor for
C                                          first solid line segment.
C                                          This can be used to off-set
C                                          labels.  For example, if
C                                          FPART = .5, the first solid
C                                          line segment is only
C                                          one-half as long as the other
C                                          solid line segments.  This
C                                          moves all labels on this
C                                          line towards the beginning,
C                                          which reduces the
C                                          probability of the label
C                                          being written on top of a
C                                          label of a nearby line
C                                          drawn with FPART = 1.
C
C                          IGP       9     Flag to control whether a gap
C                                          is left for characters when
C                                          plotting.
C                                            = 9  Gap is left.
C                                            = 0  No gap is left.
C
C                          ICLOSE    6     An internal or external call to
C                                          set the pen (pen-up) to a
C                                          specific position is executed
C                                          only if this position is
C                                          more than ICLOSE metacode
C                                          address units away from the
C                                          current pen position (distance=
C                                          difference in X-coordinates +
C                                          difference in Y-coordinates).
C
C
C
      COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE,
     1    ICLOSE
C
C USER ENTRY POINT.
C DASHDC GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS
C SPECIFIED IN ITS ARGUMENTS. THIS INTERNAL REPRESENTATION IS PASSED
C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1.
C
      CHARACTER*(*) IPAT
      CHARACTER*1   ICR
      CHARACTER*16  IPC(100)
C
C DASHD1 AND DASHD2 ARE USED
C FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB, DASHDC, AND CFVLD.
C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBDX.
C
      COMMON /DASHD1/  ISL,  L,  ISIZE,  IP(100),  NWDSM1,  IPFLAG(100)
     1                 ,MNCSTR, IGP
      COMMON /DASHD2/  IPC
C
C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB AND DASHDC.
C IT IS INITIALIZED IN DASHBDX.
C
      COMMON /DDFLAG/ IFCFLG
C
C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD)
C WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED.
C IT IS INITIALIZED IN DASHBDX AND REFERENCED IN CFVLD.
C
      COMMON /DCFLAG/ IFSTFL
C
C LOCAL VARIABLES TO DASHDB AND DASHDC ARE SAVED IN DSAVE6 FOR
C THE NEXT CALL.
C
      COMMON /DSAVE6/ MASK, NCHRWD, NBWD, MNCST1
C
C Make definitions of a blank, a gap, and a solid externally visible.
C
      COMMON /BLGASO/ IBLK,IGAP,ISOL
      CHARACTER*1     IBLK,IGAP,ISOL
C
C SAVE ALL VARIABLES
C
      SAVE
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
      CALL DASHBD
C
C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR
C
      CALL Q8QST4 ('GRAPHX', 'DASHCHAR', 'DASHDC', 'VERSION  1')
C
C     NC IS THE NUMBER OF CHARACTERS IN IPAT
C
      NC = LEN(IPAT)
      IF (IFCFLG .EQ. 2) GOTO 10
C
C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBDX ARE LOADED CORRECTLY
C
      IF (MNCSTR .EQ. 15) GOTO 6
      CALL SETER('DASHDC -- BLOCKDATA DASHBDX APPARENTLY NOT LOADED CORR
     1ECTLY',1,2)
    6 CONTINUE
C
C INITIALIZATION
C
      MNCST1 = MNCSTR + 1
C
C MASK IS AN ALL SOLID PATTERN TO BE PASSED TO OPTN (65535=177777B).
C
      MASK=IOR(ISHIFT(32767,1),1)
C
C
      IFCFLG = 2
C
C NCHRTS - NUMBER OF CHARS IN THIS HOLLERITH STRING.
C L      - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY.
C ISL    - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1).
C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS
C          CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED.
C
   10 CONTINUE
      NCHRTS = 0
      L = 0
      ISL = 0
      IFSTFL = 1
C
C RETRIEVE THE RESOLUTION AS SET BY THE USER.
C
      CALL GETUSV('XF',LXSAVE)
      CALL GETUSV('YF',LYSAVE)
C
C IADJUS - TO ADJUST NUMBERS TO THE GIVEN RESOLUTION.
C
      IADJUS = ISHIFT(1,15-LXSAVE)
      ICRT = JCRT*IADJUS
      ISIZE = JSIZE
      CHARW = REAL(ISIZE*IADJUS)
      IF (ISIZE .GT. 3) GO TO 30
      CHARW = 256. + REAL(ISIZE)*128.
      IF (ISIZE .EQ. 3) CHARW = 768.
C
   30 CONTINUE
      IF (ICRT .LT. 1) GO TO 230
      MODE = 2
C
C START MAIN LOOP
C
C THIS LOOP GENERATES THE IP ARRAY (NEEDED BY CURVED,VECTD,ETC.) FROM
C THE CHARACTER STRING IN IPAT.  EACH ITERATION OF THE LOOP PROCESSES
C ONE CHAR OF IPAT.  A SOLID OR GAP IS CONSIDERED TO BE A TYPE 1 ENTRY,
C AND A LABEL CHARACTER IS CONSIDERED TO BE A TYPE 2 ENTRY.
C
C IN THE CODE, L IS THE NUMBER OF CHANGES IN THE LINESTYLE (FROM GAP
C TO SOLID, SOLID TO CHARACTER, ETC.)  THE IP AND IPFLAG ARRAYS DESCRIBE
C THE LINE TO BE DRAWN, AND THESE ARRAYS ARE INDEXED FROM 1 TO L.  THE
C RELATIONSHIP BETWEEN IP AND IPFLAG IS:
C
C      IPFLAG(N)    IP(N)
C      ---------    -----
C          1        LENGTH (IN PLOTTER ADDRESS UNITS) OF SOLID LINE TO
C                   BE DRAWN.
C          0        NUMBER OF CHARACTERS TO BE PLOTTED.
C         -1        LENGTH (IN PLOTTER ADDRESS UNITS) OF GAP.
C
C THE 160 LOOP HANDLES 5 CASES:
C
C    1.)  CONTINUE TYPE 2 ENTRY (60-80)
C    2.)  START TYPE 2 ENTRY (80-90)
C    3.)  END TYPE 2 ENTRY AND START TYPE 1 ENTRY (90-160)
C    4.)  START TYPE 1 ENTRY, OR SWITCH TYPE 1 ENTRY FROM SOLID TO
C         GAP OR FROM GAP TO SOLID (140-160)
C    5.)  CONTINUE TYPE 1 ENTRY (150-160)
C
      DO 160 J=1,NC
C
C GET NEXT CHAR INTO ICR, RIGHT JUSTIFIED ZERO FILLED.
C
            ICR = IPAT(J:J)
C
C MODE SPECIFIES WHAT THE LAST CHARACTER PROCESSED WAS:
C
C    LAST ICR WAS $ (SOLID),      MODE IS 8
C    LAST ICR WAS ' (GAP),        MODE IS 2
C    LAST ICR WAS HOLLERITH CHAR, MODE IS 5
C
C NMODE SPECIFIES WHAT THE CURRENT CHARACTER TO BE PROCESSED IS:
C
C      ICR     NMODE
C      ---     -----
C       $        1
C       CHAR     0
C       '       -1
C
            NMODE = 0
            IF (ICR .EQ. IBLK) GO TO 160
            IF (ICR .EQ. IGAP) NMODE = -1
            IF (ICR .EQ. ISOL) NMODE = 1
            IF (L.EQ.0 .AND. NMODE.EQ.-1) MODE = 8
C
C NGO DETERMINES WHERE TO BRANCH BASED ON CASE TO BE PROCESSED.
C COMPUTE MODE FOR NEXT ITERATION.
C
            NGO = NMODE+MODE
            MODE = NMODE*3+5
            GO TO (150,80,140,90,60,90,140,80,150),NGO
C
C CHAR TO CHAR
C
C CASE 1) - CONTINUE TYPE 2 ENTRY.
C
   60      IF (NCHRTS .EQ. MNCSTR) GO TO 160
           NCHRTS = NCHRTS + 1
           IP(L) = NCHRTS
           IPC(L)(NCHRTS:NCHRTS) = ICR
           GO TO 160
C
C BLANK OR SOLID TO CHAR
C
C CASE 2) - START STRING ENTRY.  LGBSTR POINTS TO THE GAP WHICH
C           WILL CONTAIN THE STRING.
C
   80      LGBSTR = MIN(L+1,NP)
           L = MIN(LGBSTR+1,NP)
           IPFLAG(L) = 0
           NCHRTS    = 1
           IP(L)     = 1
           IPC(L)(NCHRTS:NCHRTS) = ICR
           GO TO 160
C
C CHAR TO SOLID OR GAP
C
C CASE 3) - END STRING ENTRY.  ICR IS A $ OR '.
C
   90      CONTINUE
           IP(LGBSTR) = CHARW*(REAL(NCHRTS) + .5)
           IPFLAG(LGBSTR) = -1
           IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1
C
C BLANK TO SOLID OR SOLID TO BLANK
C
C CASE 4) - START TYPE 1 ENTRY.
C
  140       L = MIN(L+1,NP)
            IP(L) = 0
C
C ADD TO A BLANK OR SOLID LINE
C
C CASE 5) - CONTINUE TYPE 1 ENTRY.  ICR IS A $ OR '.
C ADD ICRT UNITS TO THE PLOTTER ADDRESS UNITS IN IP(L).
C NMODE INDICATES IF IT IS A GAP OR A SOLID.
C
  150       IP(L) = IP(L) + ICRT
            IPFLAG(L) = NMODE
  160    CONTINUE
C
C IF LAST ICR PROCESSED WAS A LABEL CHARACTER, MUST END STRING
C ENTRY.
C
      IF (NGO.NE.2 .AND. NGO.NE.5 .AND. NGO.NE.8) GO TO 220
      IP(LGBSTR) = CHARW*(REAL(NCHRTS)+.5)
      IPFLAG(LGBSTR) = -1
      IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1
C
C IF IP ARRAY HAS ONLY ONE TYPE 1 ENTRY, SET ISL FLAG.
C
  220 IF (L .GT. 1) RETURN
      IBIG = ISHIFT(1,MAX(LXSAVE,LYSAVE))
      IF (IP(L) .GE. IBIG) GO TO 230
      IF (IPFLAG(L)) 240,240,230
  230 ISL = 1
      RETURN
  240 ISL = -1
      RETURN
      END


      SUBROUTINE SOLAR(K,NKN,XLK,DIY,SUMFB,SUMMBP,SUMDBP,FPAN,FPBN,
     .           FSDTKA,FSDTKB,NT,SSUMFB)
       IMPLICIT REAL*8(A-H,O-Z)
C
C     SOLAR PRESSURE LOADINGS
C     COMPUTES SOLAR PRESSURE FORCES AND SOLAR TEMPERATURE FORCES
C     ON ELEMENTS AND SOLAR PRESSURE MOMENT ON ENTIRE SATELLITE FOR MM=1
C     COMPUTES AERO FORCES AND AERO TEMPERATURE FORCES ON ELEMENTS
C     AND AERO MOMENT ON ENTIRE SATELLITE FOR MM=2
C     COMPUTES DAMPING FORCES FOR ELEMENTS
C     COMPUTES INTERNAL GENERALISED FORCES FOR ELEMENTS
C     SUBROUTINES REQUIRED
C          DSQRT,SHADES
C
C
      COMMON/CCMBNZ/ CMRK(10),Z01(4),Z02(4),Z03(4),Z04(4),Z11(12),
     .               Z12(12),Z13(12),Z14(12),Z15(12),Z16(12),Z21(36),
     .               Z22(36),Z23(36),Z24(36),Z25(36),Z26(36),Z27(36),
     .               Z28(36),Z31(108),Z32(108),Z33(108),Z34(108),
     .               Z35(108),Z41(324),Z42(324),Z43(324),ZK21(18),
     .               ZK22(18),ZK23(18),ZK31(54),ZK32(54),ZK33(54),
     .               ZK34(54),ZK35(54),ZK36(54),ZK41(162),ZK42(162),
     .               ZK43(162),ZK44(162),ZK45(162),ZK46(162),ZK47(162),
     .               ZK48(162),ZS01(2),ZS02(2),ZS11(6),ZS12(6),ZS13(6),
     .               ZS21(18),ZS22(18),ZS23(18),ZS24(18),ZS31(54),
     .               ZS32(54),ZS41(162),ZT21(108),ZT22(108),STAO(18),
     .               STA1(18),STA2(18),STBO(18),STB1(18),STB2(18),
     .               Z2S01(2),Z2S12(6),Z2S23(18)
C
      COMMON/CENVRN/ GGMOM(3),SPMOM(3),ADMOM(3),HUBSPM(3),HUBADM(3)
C
      COMMON/COMSOL/ ZZ01(10),ZZ12(3,10),ZZ23(9,10),SZS01(10),SZS02(10),
     1               SZS11(3,10),SZS12(3,10),SZS13(3,10),SZS21(9,10),
     1               SZS22(9,10),SZS23(9,10),SZS24(9,10),SZS31(27,10),
     1               SZS32(27,10),SZS41(81,10)
C
      COMMON/CSOLAR/ SAO(10),SKA(9),SKB(9),SKOA(10,3),SKOB(10,3),
     .               STMK(10),SKAA(10,9),SKBB(10,9)
C
      COMMON/EISUBK/ EI(10)
C
      COMMON/DEBUG2/ IOUT,JOUT,KLUGE
C
      COMMON/IPOOL1/ IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10),
     .               LK(10),LLK(10)
C
      COMMON/ISHADE/ IPLANS,ISATSH,IWRTTF
C
      COMMON/RPOOL1/ RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/RPOOL2/ PO,SD(3),DAN(3,10),DBN(3,10),CFMT(3,3),DIY1(3),
     .               SD1(3),DT1,P1,AERO,DTO1,YIZK(3),PO1
C
      COMMON/SOLOUT/ FTAKIN(10,3),FTAKOT(10,3),FTBKIN(10,3),FTBKOT(10,3)
C
      COMMON/SPRESX/ SPRES(10,3)
C
      COMMON/VARBLS/ DEPEND(150),DERIV(150)
C
C
      DIMENSION FCMT(3,3),DIY(3),DIZ(3),D(3,6),U(6),S(200),X2U(6),X3U(6)
     .         ,X1U(6),STAK1(3),STAK2(3),X2AU(6,3),X3BU(6,3),STBK1(3),
     .          STBK2(3),SPAK(9),SPBK(9),X1AL(3),X2AL(3),X3BL(3),X1BL(3)
     .         ,X1AU(6,3),X1BU(6,3),FSDTKA(3),FSDTKB(3),FK(3),FTMK(3),
     .          FPAN(3),FPBN(3),ZMZ(3),FTZK(3),FTYK(3),ZMY(3),SUMMBP(3),
     .          SUMFB(3),FITZ(3),DMAT1(10,3,6),DMAT(10,3,6),
     .          SDIY(3),SSUMFB(3)
        LTAP5=6
      DO 500 I=1,9
      SKA(I)=SKAA(K,I)
  500 SKB(I)=SKBB(K,I)
       SPRES(K,1)=0.D0
       SPRES(K,2)=0.D0
       SPRES(K,3)=0.D0
       RHO = RHOK(K)
        XLK2= XLK * XLK
       XLK4 = XLK2 * XLK2
       NKN2 = NKN * NKN
       IF(NKN)10000,10000,10001
10001  DO 170 I=1,NKN
       FSDTKA(I) = 0.0D0
       FSDTKB(I) = 0.0D0
       FPAN(I) = 0.0D0
  170  FPBN(I) = 0.0D0
10000    SK = SAO(K)
         WS1= SK * XLK
         WS2= SK / XLK
         WS3= WS2/XLK
       WS4 = 1.0D0/(RHO *XLK2)
       MM = 1
  160   CONTINUE
      IF(MM.EQ.2) CALL COMBNS(K,XLK,X1L,X2L,X3L,PO,1)
         C1 = PO/(RHO *XLK)
       C2 = PO/(RHO * XLK) *STMK(K)
       SP1 = PO * STMK(K)
       DO 9 I= 1,3
        SUM = 0.0D0
       DO 10 J=1,3
   10   SUM = SUM + CFMT(I,J) * DIY(J)
    9   DIZ(I) = SUM
        DZ1 = DIZ(1)
        DZ2 = DIZ(2)
        DZ3 = DIZ(3)
       DZ123= DZ1 * DZ2 * DZ3
       DZ11 = DZ1 * DZ1
       DZ22 = DZ2 * DZ2
       DZ33 = DZ3 * DZ3
        DEN = DZ22 + DZ33
        SQR = DSQRT(DEN)
        GO TO (102,103),MM
  103   IF(SQR)250,105,250
  105  GO TO (106,107),ITIM
  107   DO 108 I=1,3
       DO 108 J=1,6
  108  D(I,J) = DMAT1(K,I,J)
       GO TO 109
  106  DO 110 I=1,3
       DO 110 J=1,6
  110  D(I,J) = 0.0D0
       GO TO 109
  102  IF(SQR)250,251,250
  251   GO TO (252,401),ITIM
  401  DO 402 I=1,3
       DO 402 J=1,6
  402  D(I,J) = DMAT(K,I,J)
        GO TO 255
  252   DO 254 I=1,3
       DO 254 J=1,6
  254  D(I,J) = 0.0D0
       GO TO 255
  250  D(1,1) = 0.0D0
       D(1,2)= -DZ2 * SQR
        DEN1 = DZ11/DEN
        DEN2 = DZ22/DEN
        DEN3 = DZ33/DEN
       D(1,3)= -DZ3 * SQR
       D(1,4)= DZ1 * SQR * (1.0D0 + DEN2)
       D(1,5)= DZ1 * SQR * (1.0D0 + DEN3)
       D(1,6)= 2.0D0* SQR* DZ123/DEN
       D(2,1)= DZ2 * SQR
       D(2,2)=-DZ1 * SQR * (1.0D0 + DEN2)
       D(2,3)=-DZ123*SQR/DEN
       D(2,4)=-0.5D0 * DZ2/SQR * (2.0D0 -5.0D0* DZ11 + DEN2)
       D(2,5)=-0.5D0 * DZ2/SQR * (DEN3 - DZ11)
       D(2,6)= - DZ3/SQR * (1.0D0 -2.0D0* DZ11 + DEN2)
       D(3,1)=  DZ3  * SQR
       D(3,2)= -DZ123* SQR/DEN
       D(3,3) = -DZ1* SQR *(1.0D0 + DEN3)
       D(3,4) = -0.5D0 * DZ3/SQR *(DEN2 - DZ11)
       D(3,5) = -0.5D0 * DZ3/SQR *(2.0D0- 5.0D0* DZ11 + DEN3)
   11  D(3,6) = -DZ2/SQR * (1.0D0 -2.0D0 *DZ11+ DEN3)
       GO TO (255,109),MM
  109   DO 111 I=1,3
       DO 111 J=1,6
  111  DMAT1(K,I,J) = D(I,J)
       GO TO 112
  255  CONTINUE
       DO 400 I=1,3
       DO 400 J=1,6
  400  DMAT(K,I,J) = D(I,J)
  112  GO TO (20002,20003),IOUT
20003  CONTINUE
      WRITE (LTAP5,9000) DZ1,DZ2,DZ3,SQR
 9000 FORMAT(1H0,'DZ1=',E18.8,2X,'DZ2=',E18.8,2X,'DZ3=',E18.8,2X,'SQR=',
     1E18.8)
      WRITE (LTAP5,9001) ((D(I,J),J=1,6),I=1,3)
 9001 FORMAT(1H0,'D=',6E20.8)
20002  CONTINUE
       DO 100 IL=1,200
  100   S(IL) = 0.0D0
         I1 = IAB + NT
         I2 = IBB + NT
       I3 = IAPS + NT
       I4 = IBPS + NT
      X1L=0.D0
      X2L=0.D0
      X3L=0.D0
        DO 101 IL =1,6
         U(IL) = 0.0D0
      X1U(IL)=0.D0
       X2U(IL) = 0.0D0
  101  X3U(IL) = 0.0D0
       U(1) = WS1 * SZS01(K)
         NN = 1
      LLL=LLK(K)-1
       IF(NKN)200,300,200
  200   DO 2 N=1,NKN
         N1 = N-1
         AN = DEPEND(I1+ N1)
         BN = DEPEND(I2+ N1)
       DO 42 I=1,3
         STBK1(I) = 0.0D0
         STBK2(I) = 0.0D0
        STAK1(I) = 0.0D0
   42   STAK2(I) = 0.0D0
       GO TO (118,119),MM
  118   FDKA = DAN(N,K) * DEPEND(I3+N1)*WS4
       FDKB = DBN(N,K) * DEPEND(I4+N1)*WS4
       U(2) =U(2)+ AN * SZS11(NN,K)
       U(3) =U(3)+ BN * SZS11(NN,K)
        X2AU(1,N) = WS1 * SZS12(NN,K)
        X3BU(1,N) = X2AU(1,N)
       S(50) = 0.0D0
       S(51) = 0.0D0
       DO 40 I=1,9
         SPAK(I) = 0.0D0
   40    SPBK(I) = 0.0D0
  119    DO 3 IP=1,NKN
      NP=(N-1)*3 + IP
      NPK=LLL*9+NP
      S21=SZS21(NP,K)
      IP1=IP-1
      AP=DEPEND(I1+IP1)
      BP=DEPEND(I2+IP1)
      RAP=AP - SKOA(K,IP)
      RBP=BP - SKOB(K,IP)
       GO TO (120,121),MM
  120  AB = AN * BP
         AA = AN * AP
         BB = BN * BP
C     ADD TO N AND IP LOOP
      SPAK(1)=SPAK(1)+RAP*ZK21(NPK)
      SPAK(2)=SPAK(2)+RBP*ZK22(NPK)
      SPBK(1)=SPBK(1)+RAP*ZK22(NPK)
      SPBK(2)=SPBK(2)+RBP*ZK23(NPK)
        S(50) = S(50) + AP * ZZ23(NP,K)
        S(51) = S(51) + BP * ZZ23(NP,K)
       U(4) =U(4)+ AA * S21
       U(5) =U(5)+ BB * S21
       U(6) =U(6)+ AB * S21
       S23 = SZS23(NP,K)
       S(1)= S(1) + AP * S23
       S22 = SZS22(NP,K)
       S(2)= S(2) + AP * S22
       S(3)= S(3) + BP * S22
       S(4)= S(4) + BP * S23
      DO 4 IQ =1,NKN
      NQ=(N-1)*9 + (IP-1)*3 + IQ
      NQK=LLL*27+NQ
        IQ1 = IQ -1
        AQ = DEPEND(I1 + IQ1)
        BQ = DEPEND(I2 + IQ1)
       APQ = AP * AQ
       AB  = AP * BQ
       BPQ = BP * BQ
      RAQ=AQ - SKOA(K,IQ)
      RBQ=BQ - SKOB(K,IQ)
      RAPQ=RAP*RAQ
      RAB=RAP*RBQ
      RBPQ=RBP*RBQ
C     ADD TO N IP AND IQ LOOP
      SPAK(3)=SPAK(3)+(RAPQ*ZK31(NQK))/XLK
      SPAK(4)=SPAK(4)+(RAB *ZK32(NQK))/XLK
      SPAK(5)=SPAK(5)+(RBPQ*ZK33(NQK))/XLK
      SPBK(3)=SPBK(3)+(RAPQ*ZK34(NQK))/XLK
      SPBK(4)=SPBK(4)+(RAB *ZK35(NQK))/XLK
      SPBK(5)=SPBK(5)+(RBPQ*ZK36(NQK))/XLK
       S31 = SZS31(NQ,K)
       S32 = SZS32(NQ,K)
       S(7)= S(7) + AQ * S31
       S(8)= S(8) + BQ * S31
       S(9)= S(9) + AQ * S32
       S(10)= S(10)+ BQ* S32
      DO 5 IR =1,NKN
      NR=(N-1)*27 + (IP-1)*9 + (IQ-1)*3 + IR
      NRK=LLL*81+NR
         IR1 = IR -1
         AR = DEPEND(I1 + IR1)
         BR = DEPEND(I2 + IR1)
      RAR=AR - SKOA(K,IR)
      RBR=BR - SKOB(K,IR)
        S41 = SZS41(NR,K)
        S(5)= S(5) + AR* AQ * S41
        S(6)= S(6) + BR* BQ * S41
       S(11)=S(11) + AQ* BR * S41
C     ADD TO N IP IQ IR LOOP
      SPAK(6)=SPAK(6)+(RAPQ*RAR*ZK41(NRK))/XLK2
      SPAK(7)=SPAK(7)+(RAPQ*RBR*ZK42(NRK))/XLK2
      SPAK(8)=SPAK(8)+(RAB *RBR*ZK43(NRK))/XLK2
      SPAK(9)=SPAK(9)+(RBPQ*RBR*ZK44(NRK))/XLK2
      SPBK(6)=SPBK(6)+(RAPQ*RAR*ZK45(NRK))/XLK2
      SPBK(7)=SPBK(7)+(RAPQ*RBR*ZK46(NRK))/XLK2
      SPBK(8)=SPBK(8)+(RAB *RBR*ZK47(NRK))/XLK2
      SPBK(9)=SPBK(9)+(RBPQ*RBR*ZK48(NRK))/XLK2
    5 CONTINUE
    4 CONTINUE
       S(12) = S(12) + S(7) * AP
       S(13) = S(13) + S(8) * BP
       S(14) = S(14) + S(8) * AP
       S(15) = S(15) + S(7) * BP
       S(16) = S(16) + S(5) * AP
       S(17) = S(17) + S(6) * AP
       S(18) = S(18) + S(11)* AP
       S(19) = S(19) + S(9) * AP
       S(20) = S(20) + S(10)* BP
       S(21) = S(21) + S(10)* AP
       S(22) = S(22) + S(5) * BP
       S(23) = S(23) + S(6) * BP
       S(24) = S(24) + S(11)* BP
  121   CONTINUE
C     ADD TO N AND IP LOOP FOR THERMAL FORCES
      NPA=LLL*54+NP
      NPB=NPA+27
      STAK1(1)=STAK1(1)+(AP*ZT21(NPA))/XLK
      STAK2(1)=STAK2(1)+(BP*ZT21(NPB))/XLK
      STBK1(1)=STBK1(1)+(AP*ZT22(NPA))/XLK
      STBK2(1)=STBK2(1)+(BP*ZT22(NPB))/XLK
      NPA=NPA+9
      NPB=NPB+9
      STAK1(2)=STAK1(2)+(AP*ZT21(NPA))/XLK
      STAK2(2)=STAK2(2)+(BP*ZT21(NPB))/XLK
      STBK1(2)=STBK1(2)+(AP*ZT22(NPA))/XLK
      STBK2(2)=STBK2(2)+(BP*ZT22(NPB))/XLK
      NPA=NPA+9
      NPB=NPB+9
      STAK1(3)=STAK1(3)+(AP*ZT21(NPA))/XLK
      STAK2(3)=STAK2(3)+(BP*ZT21(NPB))/XLK
      STBK1(3)=STBK1(3)+(AP*ZT22(NPA))/XLK
      STBK2(3)=STBK2(3)+(BP*ZT22(NPB))/XLK
    3 CONTINUE
       GO TO (122,123),MM
  122  WS = -S(50)/XLK
       X1AL(N) = WS
       S(52) = S(52) + AN * WS
       WS = ZZ12(NN,K)
        X2AL(N) = WS
        S(55) = S(55) + BN * WS
       X3BL(N) = WS
       S(54) = S(54) + AN * WS
       WS = -S(51)/XLK
        X1BL(N) = WS
       S(53) = S(53) + BN * WS
       X1AU(1,N) = SK * S(1)
       X1AU(2,N) = WS2* S(12)
       X1AU(3,N) = WS2* S(14)
       X1AU(4,N) = WS3* S(16)
       X1AU(5,N) = WS3* S(17)
       X1AU(6,N) = WS3* S(18)
       X2AU(2,N) = SK * S(2)
       X2AU(3,N) = SK * S(3)
       X2AU(4,N) = WS2* S(19)
       X2AU(5,N) = WS2* S(20)
       X2AU(6,N) = WS2* S(21)
       X1BU(1,N) = SK * S(4)
       X1BU(2,N) = WS2* S(15)
       X1BU(3,N) = WS2* S(13)
       X1BU(4,N) = WS3* S(22)
       X1BU(5,N) = WS3* S(23)
       X1BU(6,N) = WS3* S(24)
       X3BU(2,N) = SK * S(2)
       X3BU(3,N) = SK * S(3)
       X3BU(4,N) = WS2* S(19)
       X3BU(5,N) = WS2* S(20)
       X3BU(6,N) = WS2* S(21)
       SUM1 = 0.0D0
       SUM2 = 0.0D0
       DO 41 I=1,9
        SUM1= SUM1 + SKA(I) * SPAK(I)
   41   SUM2= SUM2 + SKB(I) * SPBK(I)
       FSKA = (SUM1/XLK4)/RHO
       FSKB = (SUM2 /XLK4)/RHO
  123   NN = NN +1
        SUM1= 0.0D0
        SUM2= 0.0D0
         II = N
C     CHANGE THERMAL FORCE COMPUTATION
      JJJJJJ=LLL*9
       DO 43 I=1,3
C     THIS GOES IN DO 43 LOOP
      JJ=JJJJJJ+II
      SUM1=SUM1+DIZ(I)*(STAO(JJ)+STA1(JJ)*STAK1(I)+STA2(JJ)*STAK2(I))
      SUM2=SUM2+DIZ(I)*(STBO(JJ)+STB1(JJ)*STBK1(I)+STB2(JJ)*STBK2(I))
         II  = II +3
   43  CONTINUE
      FTAK= DTO*EI(K)*SUM1/(RHO*XLK2)
      FTBK= DTO*EI(K)*SUM2/(RHO*XLK2)
       GO TO (150,151), MM
  150  IF(IPLANS.EQ. 0.AND.ISATSH .EQ.0)GO TO 151
       FTAKIN (K,N)=FTAK
       FTBKIN (K,N)=FTBK
       CALL SHADES (K, N, DIZ, FTAK, FTBK)
       FTAKOT(K,N)=FTAK
       FTBKOT (K,N) =FTBK
  151  CONTINUE
      GO TO (20005,20006),IOUT
20006  CONTINUE
      WRITE (LTAP5,9006) FTAK,FSKA,FDKA,FTBK,FSKB,FDKB
 9006 FORMAT(1H0,'9006',6E20.8)
20005  CONTINUE
       FSDTKA(N) = FTAK + FSKA + FDKA + FSDTKA(N)
       FSDTKB(N) = FTBK + FSKB + FDKB + FSDTKB(N)
    2 CONTINUE
       FDKA = 0.0D0
       FDKB = 0.0D0
       FSKA = 0.0D0
       FSKB = 0.0D0
       GO TO (124,125),MM
  124   CONTINUE
       U(2) = SK * U(2)
       U(3) = SK * U(3)
       U(4) = WS2 * U(4)
       U(5) = WS2 * U(5)
       U(6) = WS2 * U(6)
       NN =1
      DO 6 N = 1,NKN
        N1 = N-1
        AN = DEPEND(I1 + N1)
        BN = DEPEND(I2 + N1)
        IC = 31
       DO 7 JC =1,6
        S(IC) = S(IC) + AN* X1AU(JC,N)+ BN * X1BU(JC,N)
       X2U(JC)= X2U(JC) + AN * X2AU(JC,N)
       X3U(JC) = X3U(JC) + BN * X3BU(JC,N)
    7   IC = IC +1
       S13 = SZS13(NN,K)
       S(37) = S(37)+ AN  *S13
       S(38) = S(38)+ BN    *S13
       DO 8 IP=1,NKN
      NP=(N-1)*3 + IP
        S24 = SZS24(NP,K)
       IP1 = IP-1
       AP= DEPEND(I1+ IP1)* S24
       BP= DEPEND(I2+ IP1)* S24
       S(39) = S(39)+ AP* AN
       S(40) = S(40)+ BP* BN
       S(41) = S(41)+ BP* AN
    8 CONTINUE
    6   NN = NN +1
  125   DO 21 I=1,NKN
       FAN = C2 *(DZ1 * X1AL(I) + DZ2*X2AL(I))
       FBN = C2 *(DZ1*X1BL(I) + DZ3*X3BL(I))
        FNA = 0.0D0
        FNB = 0.0D0
       DO 22 J=1,6
       FNA = FNA - D(1,J) *X1AU(J,I) + D(2,J) * X2AU(J,I)
   22   FNB = FNB - D(1,J) *X1BU(J,I) + D(3,J) * X3BU(J,I)
       FPAN(I) = FPAN(I) + FAN + C1 * FNA
       FPBN(I) = FPBN(I) + FBN + C1 * FNB
   21  CONTINUE
  300 CONTINUE
       X1L = XLK * ZZ01(K) + 0.5D0 * (S(52) + S(53))
        X2L = S(54)
       X3L = S(55)
       X1U(1) = WS1* XLK * SZS02(K) -0.5D0 * S(31)
       X1U(2) = WS1* S(37)-0.5D0 *      S(32)
       X1U(3) = WS1* S(38)-0.5D0 *      S(33)
       X1U(4) = SK * S(39)-0.5D0 *      S(34)
       X1U(5) = SK * S(40)-0.5D0 *      S(35)
       X1U(6) = SK * S(41)-0.5D0 *      S(36)
      DO 12 I=1,3
        FTMK(I) = SP1 * DIZ(I)
        SUM = 0.0D0
       DO 13 J=1,6
   13   SUM = SUM + D(I,J)* U(J)
       SUM = SUM * PO
        FK(I) = SUM
      FTZK (I) =  SUM  + FTMK (I)
   12 SPRES  (K, I) =  FTZK(I)  +SPRES(K,I)
       C1 = PO
       C2 = PO * STMK(K)
       ZMZ(1) = C2 *(DZ3 * X2L - DZ2 * X3L)
       ZMZ(2) = C2 *(DZ1 * X3L - DZ3 * X1L)
       ZMZ(3) = C2 *(DZ2 * X1L - DZ1 * X2L)
       DO 23 I=1,6
       ZMZ(1) = ZMZ(1) +(D(3,I)     *X2U(I) - D(2,I)*X3U(I)) * C1
       ZMZ(2) = ZMZ(2) +(D(1,I) *X3U(I) - D(3,I) * X1U(I)  ) * C1
       ZMZ(3) = ZMZ(3) +(D(2,I) *X1U(I) - D(1,I) * X2U(I)  ) * C1
   23  CONTINUE
       DO 24 I=1,3
       SUM = 0.0D0
       SUM1 = 0.0D0
       SUM2 = 0.0D0
       DO 25 J=1,3
       ZFCM = FCM(I,J)
       SUM = SUM + ZFCM*FTZK(J)
       SUM2 = SUM2 + CMAT(I,J) * FTZK(J)
   25   SUM1 = SUM1 + ZFCM * ZMZ(J)
       GO TO (140,141),MM
  141  SSUMFB(I) = SSUMFB(I) + SUM
       GO TO 142
  140   SUMFB(I) = SUMFB(I) + SUM
  142  FITZ(I) = SUM2
       FTYK(I) = SUM
   24   ZMY(I) = SUM1
      SUMMBP(1) = SUMMBP(1)  + ZMY(1) - FTYK(2)*YIZK(3)+FTYK(3)*YIZK(2)
      SUMMBP(2) = SUMMBP(2) + ZMY(2)+FTYK(1)*YIZK(3) - FTYK(3)*YIZK(1)
      SUMMBP(3) = SUMMBP(3) +ZMY(3) -FTYK(1) *YIZK(2) +FTYK(2)*YIZK(1)
       GO TO (640,641),MM
  641 CONTINUE
      ADMOM(1)  = ADMOM(1)   + ZMY(1) - FTYK(2)*YIZK(3)+FTYK(3)*YIZK(2)
      ADMOM(2)  = ADMOM(2)  + ZMY(2)+FTYK(1)*YIZK(3) - FTYK(3)*YIZK(1)
      ADMOM(3)  = ADMOM(3)  +ZMY(3) -FTYK(1) *YIZK(2) +FTYK(2)*YIZK(1)
  640 CONTINUE
      SPMOM(1)  = SPMOM(1)   + ZMY(1) - FTYK(2)*YIZK(3)+FTYK(3)*YIZK(2)
      SPMOM(2)  = SPMOM(2)  + ZMY(2)+FTYK(1)*YIZK(3) - FTYK(3)*YIZK(1)
      SPMOM(3)  = SPMOM(3)  +ZMY(3) -FTYK(1) *YIZK(2) +FTYK(2)*YIZK(1)
       IF(K-K1)26,26,27
   26   SUM = ZBZK(3,K) *FITZ(1) - ZBZK(1,K) *FITZ(3)
       DO 28 I=1,3
       SUM = SUM + CMAT(2,I) * ZMZ(I)
   28  SUMDBP = SUMDBP + SUM
   27   CONTINUE
       GO TO (130,131),MM
  130   MM = 2
       SPO = PO
       PO = P1
       SDTO = DTO
       DTO = DT1
       DO 132 I=1,3
       SDIY(I) = DIY(I)
       DIY(I) = DIY1(I)
  132  CONTINUE
       GO TO 160
  131    PO = SPO
       DTO = SDTO
       DO 134 I=1,3
       DIY(I) = SDIY(I)
  134  CONTINUE
      CALL COMBNS(K,XLK,X1L,X2L,X3L,PO,2)
C
      RETURN
      END


	SUBROUTINE GWTHR ( sys, np, wtcod, x, y, ixoff, iyoff, iret )
C************************************************************************
C* GWTHR								*
C*									*
C* This subroutine plots weather symbols in any coordinate system.	*
C* The symbols are drawn using attributes defined by GSWTHR.		*
C*									*
C* GWTHR ( SYS, NP, WTCOD, X, Y, IXOFF, IYOFF, IRET )			*
C*									*
C* Input parameters:							*
C*	SYS		CHAR*		Coordinate system		*
C*                                        'S' = screen coordinates      *
C*					  'D' = device coordinates	*
C*					  'N' = normalized coordinates	*
C*					  'V' = view coordinates	*
C*					  'P' = plot coordinates	*
C*					  'M' = map coordinates		*
C*					  'G' = grid coordinates	*
C*	NP		INTEGER		Number of symbols		*
C*	WTCOD (NP)	REAL		Weather symbol codes		*
C*	X     (NP)	REAL		X coordinates / latitudes	*
C*	Y     (NP)	REAL		Y coordinates / longitudes	*
C*	IXOFF (NP)	INTEGER		X offsets in half characters	*
C*	IYOFF (NP)	INTEGER		Y offsets in half characters	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* S. Schotz/GSC	 3/90	GEMPLT Version 5.0			*
C* S. Schotz/GSC	 5/90	Changed weather code to real		*
C* M. desJardins/NMC	 3/92	Clean up				*
C* M. Linda/GSC		 6/96	Bypass buffer /WTHRBF/ when NP > 1	*
C* M. Linda/GSC		12/96	Removed /WTHRBF/, passing reals on down	*
C* S. Jacobs/NCEP	 3/97	Added check for VG driver		*
C* C. Lin/EAI	 	 6/97	Modified for adding 'S' in sysup	*
C* S. Schotz/NCEP        7/97   Update documentation for S coordinate   *
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'DEVSET.CMN'
	INCLUDE		'DEVCHR.CMN'
	INCLUDE		'DEVACT.CMN'
	INCLUDE		'GTBUFF.CMN'
C*
	CHARACTER*(*)	sys
	REAL		wtcod (*), x (*), y (*)
	INTEGER		ixoff (*), iyoff (*)
C
	CHARACTER	sysuc*1, sysout*1
C
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Check for zero points.
C
	IF ( np .le. 0 ) RETURN
C
C*	Check that device has been set.
C
	IF  ( ddev .eq. ' ' ) THEN
	    iret = NDVICE
	    RETURN
	END IF
C
C*	Find coordinate system for clipping.
C
	CALL ST_LCUC ( sys, sysuc, ier )
	isys = INDEX ( sysup, sysuc )
	IF  ( isys .eq. 0 ) THEN
	    iret = NOCORD
	    RETURN
	ELSE
	    iwndw = isys - 2
	    IF ( iwndw .gt. 3 ) iwndw = 3
	    IF ( iwndw .le. 0 ) iwndw = 1
	END IF
C
C*	Reset color if necessary.
C
	IF ( lcolr .ne. mcolr ) CALL DSCOLR ( lcolr, jcm, ier )
C
C*	Set the output coordinates based on the device driver.
C
	IF  ( ddev .eq. 'VG' )  THEN
	    sysout = 'M'
	  ELSE
	    sysout = 'D'
	END IF
C
C*	Loop when points will not fit in one buffer.
C
	npass = ( ( np - 1 ) / LLMXPT ) + 1
	ib = 1
	DO  m = 1, npass
	    ie = ib + LLMXPT - 1
	    IF ( ie .gt. np ) ie = np
	    num = ie - ib + 1
C
C*	    Transform to device coordinates.
C
	    CALL GTRANS ( sysuc, sysout, num, x (ib), y (ib),
     +			  gx, gy, ier )
C
C*	    Send symbols to device driver.
C
	    CALL DWTHR ( iwndw, num, wtcod (ib), gx, gy, ixoff (ib),
     +			 iyoff (ib), iret )
	    ib = ie + 1
	END DO
C*
	RETURN
	END