C Returns picture body data given pb name (12 characters)
C
      SUBROUTINE PBDATA(name,BUF,*)

      REAL*4 BUF(*)
      INTEGER N,J,K
      INTEGER*4 id(65)
      REAL*4 SRANGE(11)
      REAL*4 RADPE(4,65),
     +       radpe_1(4,16),radpe_2(4,16),radpe_3(4,16),radpe_4(4,17)
      equivalence(radpe_1,radpe(1,1))
      equivalence(radpe_2,radpe(1,17))
      equivalence(radpe_3,radpe(1,33))
      equivalence(radpe_4,radpe(1,49))

      REAL*4 ROT(65)
      character*12 p8,pname(65)
      character*12 name
      data n/65/
      data id/
c mercury
     + 1,
c venus
     + 2,
c earth
     + 3,3,
c mars
     + 4,4,4,
c jupiter
     + 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
c saturn
     + 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
c uranus
     + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
c neptune
     + 8,8,8,
c pluto
     + 9,9,
c gaspra
     + 10,
c ida
     + 11/

       Data Pname /   'MERCURY     ','VENUS       ','EARTH       ',
     + 'MOON        ','MARS        ','PHOBOS      ','DEIMOS      ',
     + 'JUPITER     ','IO          ','EUROPA      ','GANYMEDE    ',
     + 'CALLISTO    ','AMALTHEA    ','HIMALIA     ','ELARA       ',
     + 'PASIPHAE    ','SINOPE      ','LYSITHEA    ','CARME       ',
     + 'ANANKE      ','LEDA        ','THEBE       ','ADRASTEA    ',
     + 'METIS       ','SATURN      ','MIMAS       ','ENCELADUS   ',
     + 'TETHYS      ','DIONE       ','RHEA        ','TITAN       ',
     + 'HYPERION    ','IAPETUS     ','PHOEBE      ','JANUS       ',
     + 'EPIMETHEUS  ','HELENE      ','TELESTO     ','CALYPSO     ',
     + 'ATLAS       ','PROMETHEUS  ','PANDORA     ','URANUS      ',
     + 'ARIEL       ','UMBRIEL     ','TITANIA     ','OBERON      ',
     + 'MIRANDA     ','CORDELIA    ','OPHELIA     ','BIANCA      ',
     + 'CRESSIDA    ','DESDEMONA   ','JULIET      ','PORTIA      ',
     + 'ROSALIND    ','BELINDA     ','PUCK        ','NEPTUNE     ',
     + 'TRITON      ','NEREID      ','PLUTO       ','CHARON      ',
     + 'GASPRA      ','IDA         ' /
C
C Planet radii ra,rb,rc,lora in km & degrees
C where ra = (major) equatorial radius at longitude lora
C       rb = equatorial radius at longitude lora + 90 degrees
C       rc = polar radius (km)
      data RADPE_1/
C        MERCURY                         VENUS
     *2439.7,2439.7,2439.7,0.,        6137.,6137.,6137.,0.,
C        EARTH                           MOON
     *6378.14,6378.14,6356.75,0.,     1737.4,1737.4,1737.4,0.,
C        MARS                            PHOBOS
     *3397.,3397.,3375.,0.,             13.4,11.2,9.2,0.,
C        DEIMOS
     *7.5,6.1,5.2,0.,
C        JUPITER                         IO
     *71492.,71492.,66854.,0.,         1830.,1818.7,1815.3,0.,
C        EUROPA                         GANYMEDE
     *1565.,1565.,1565.,0.,            2634.,2634.,2634.,0.,
C        CALLISTO                       AMALTHEA
     *2403.,2403.,2403.,0.,            131.,73.,67.,0.,
C        HIMALIA                        ELARA
     *85.,85.,85.,0.,                  40.,40.,40.,0.,
C        PASIPHAE
     *18.,18.,18.,0./

      data radpe_2/
c        SINOPE
     *14.,14.,14.,0.,
C        LYSITHEA                       CARME
     *12.,12.,12.,0.,                  15.,15.,15.,0.,
C        ANANKE                         LEDA
     *10.,10.,10.,0.,                   5.,5.,5.,0.,
C        THEBE                          ADRASTEA
     *55.,55.,45.,0.,                    13.,10.,8.,0.,
C        METIS
     *20.,20.,20.,0.,
C        SATURN
     *60268.,60268.,54364.,0.,
C        MIMAS                          ENCELADUS
     *210.3,197.4,192.6,0.,            256.2,247.3,244.,0.,
C        TETHYS                         DIONE
     *523.,523.,523.,0.,               560.,560.,560.,0.,
C        RHEA                           TITAN
     *764.,764.,764.,0.,               2575.,2575.,2575.,0.,
C        HYPERION
     *180.,140.,112.5,0./

      data radpe_3/
c          IAPETUS
     *718.,718.,718.,0.,
C        PHEOBE                         JANUS
     *115.,110.,105.,0.,                97.,95.,77.,0.,
C       EPIMETHEUS                      HELENE
     *69.,55.,55.,0.,                    17.5,17.5,17.5,0.,
C       TELESTO                         CALYPSO
     *15.2,12.5,7.5,0.,                  15.,8.,8.,0.,
C       ATLAS                           PROMETHEUS
     *18.5,17.2,13.5,0.,                74.,50.,34.,0.,
C       PANDORA
     *55.,44.,31.,0.,
C       URANUS 			        ARIEL
     *25559.0,25559.0,24973.0,0.,      581.1,577.9,577.7,0.,
C       UMBRIEL			         TITANIA
     *584.7,584.7,584.7,0.,            788.9,788.9,788.9,0.,
C       OBERON                          MIRANDA
     *761.4,761.4,761.4,0.,            240.4,234.2,232.9,0./

      data radpe_4/
C       CORDELIA                        OPHELIA
     *13.0,13.0,13.0,0.,               15.0,15.0,15.0,0.,
C       BIANCA                          CRESSIDA
     *21.,21.,21.,0.,                  31.,31.,31.,0.,
C       DESDEMONA                       JULIET
     *27.,27.,27.,0.,                  42.,42.,42.,0.,
C       PORTIA                          ROSALIND
     *54.,54.,54.,0.,                  27.,27.,27.,0.,
C       BELINDA                         PUCK
     *33.,33.,33.,0.,                  77.,77.,77.,0.,
C       NEPTUNE                         TRITON
     *25269.,25269.,24800.,0.,         1352.6,1352.6,1352.6,0.,
C       NEREID
     *170.,170.,170.,0.,
C       PLUTO                           CHARON
     *1162.,1162.,1162.,0.,            606.,606.,606.,0.,
C       GASPRA                          IDA
     *9.,5.5,5.,0.,                    28.,12.,10.5,0./

C AXIAL ROTATION RATE (DEGREES PER DAY)
      data ROT/
C MERCURY,VENUS,EARTH,MOON
     &6.1385025,-1.4813291,360.9856235,13.1763581,
C MARS,PHOBOS,DEIMOS
     &350.9819830,1128.8444790,285.161903,
C JUPITER,IO,EUROPA,GANYMEDE,CALLISTO,
     &870.536,203.4889538,101.3747235,50.3176081,21.5710715,
C AMALTHEA,HIMALIA,ELARA,PASIPHAE,SINOPE,LYSITHEA,
     &722.6303746,1.4365522,1.384083,0.4897959,0.474934,1.3846153,
C CARME,ANANKE,LEDA,THEBE,ADRASTEA,METIS
     &0.5202312,0.5834683,1.5,0.,0.,0.,
C SATURN,MIMAS,ENDELADUS,TETHYS,DIONE,
     &810.7939024,381.994555,262.7318996,190.6979085,131.5349316,
C RHEA,TITAN,HYPERION,IAPETUS,PHOEBE,JANUS,EPIMETHEUS,HELENE,TELESTO,
     &79.6900478,22.5769768,16.91729,4.5379572,0.6540697,0.,0.,0.,0.,
C CALYPSO,ATLAS,PROMETHEUS,PANDORA,
     &0.,0.,0.,0.,
C URANUS,ARIEL,UMBRIEL,TITANIA,OBERON,
     &-501.1600928,-142.8356681,-86.8688923,-41.3514316,-26.7394932,
C MIRANDA,CORDELIA,OPHELIA,BIANCA,CRESSIDA,DESDEMONA,JULIET,PORTIA,
     &-254.6906892,0.,0.,0.,0.,0.,0.,0.,
C ROSALIND,BELINDA,PUCK,NEPTUNE,TRITON,NEREID,PLUTO,CHARON
     &0.,0.,0.,483.7625981,-61.2572684,0.999549,-56.364,-56.3624607,
C GASPRA,IDA
     &0.,0./

C Mean solar ranges of the planets (AU)...
      data SRANGE/0.387098,0.723331,1.0,1.523679,5.2027,9.546,
     &   19.2,30.09,39.5,2.2016,2.9485/
C

      p8=name
C
      DO 50 J=1,N
      IF(PNAME(J).EQ.P8) GOTO 51
   50 CONTINUE
      RETURN1
C
   51 CALL MVE(7,4,RADPE(1,J),BUF,1,1)
      IF (ROT(J) .EQ. 0) THEN
        BUF(5) = 0
      ELSE
        BUF(5) = 360.D0 / ROT(J)	!Rotation period in days
      ENDIF
      K = ID(J)
      BUF(6) = 149597871.D0*SRANGE(K)	!Solar range in km
      RETURN
      END


 module module_mosaic_drydep
 contains
 subroutine mosaic_drydep_driver( &
  id, curr_secs, ktau, dtstep, config_flags, &
  gmt, julday, &
  t_phy, rho_phy, p_phy, &
  ust, aer_res, &
  moist, chem, ddvel, &
  ids,ide, jds,jde, kds,kde, &
  ims,ime, jms,jme, kms,kme, &
  its,ite, jts,jte, kts,kte )
 use module_configure, only: grid_config_rec_type, num_moist, num_chem
 use module_state_description, only: param_first_scalar
 use module_data_mosaic_asect
 use module_data_mosaic_other
 use module_mosaic_driver, only: mapaer_tofrom_host
 use module_peg_util, only: peg_error_fatal
 implicit none
 integer, intent(in) :: &
  id, ktau, julday
 integer, intent(in) :: &
  ids, ide, jds, jde, kds, kde, &
  ims, ime, jms, jme, kms, kme, &
  its, ite, jts, jte, kts, kte
    real(kind=8), intent(in) :: curr_secs
 real, intent(in) :: dtstep, gmt
 real, intent(in), &
  dimension( ims:ime, kms:kme, jms:jme ) :: &
  t_phy, rho_phy, p_phy
 real, intent(in), &
  dimension( ims:ime, jms:jme ) :: &
  ust
 real, intent(in), &
  dimension( its:ite, jts:jte ) :: &
  aer_res
 real, intent(in), &
  dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: &
  moist
 real, intent(inout), &
  dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: &
  chem
 real, intent(inout), &
  dimension( its:ite, jts:jte, 1:num_chem ) :: &
  ddvel
 type(grid_config_rec_type), intent(in) :: config_flags
 integer idum, jdum
 integer it, jt, kt
 integer iphase, itype
 integer ktmaps, ktmape
 integer ll, l1, n
 integer levdbg_err, levdbg_info
 integer idiagaa_dum, ijcount_dum
 real dum
 real vdep_aer(maxd_asize,maxd_atype,maxd_aphase)
 character*100 msg
 ktmaps = kts
 ktmape = kts
 ktot = 1
 lunerr = -1
 lunout = -1
 levdbg_err = 0
        levdbg_info = 15
 iymdcur = 20030822
 ihmscur = 0
 ihmscur = nint( mod( real(gmt*3600.,8)+curr_secs, 86400.0_8 ) )
 t = curr_secs
 ncorecnt = ktau - 1
 itot = ite
 jtot = jte
 nsubareas = 1
 ijcount_dum = 0
 do 2920 jt = jts, jte
 do 2910 it = its, ite
 ijcount_dum = ijcount_dum + 1
 call mapaer_tofrom_host( 0, &
  ims,ime, jms,jme, kms,kme, &
  its,ite, jts,jte, kts,kte, &
  it, jt, ktmaps,ktmape, &
  num_moist, num_chem, moist, chem, &
  t_phy, p_phy, rho_phy )
 idiagaa_dum = 1
 idiagaa_dum = 0
 if ((jt.ne.jts) .and. (jt.ne.jte) .and. &
   (jt.ne.(jts+jte)/2)) idiagaa_dum = 0
 if ((it.ne.its) .and. (it.ne.ite) .and. &
   (it.ne.(its+ite)/2)) idiagaa_dum = 0
 call mosaic_drydep_1clm( idiagaa_dum, it, jt, &
  ust(it,jt), aer_res(it,jt), vdep_aer )
 do iphase = 1, nphase_aer
 do itype = 1, ntype_aer
 do n = 1, nsize_aer(itype)
     do ll = -2, ncomp_plustracer_aer(itype)
  if (ll .eq. -2) then
             l1 = numptr_aer(n,itype,iphase)
  else if (ll .eq. -1) then
      l1 = -1
      if (iphase .eq. ai_phase) l1 = waterptr_aer(n,itype)
  else if (ll .eq. 0) then
      l1 = -1
      if (iphase .eq. ai_phase) l1 = hyswptr_aer(n,itype)
  else
      l1 = massptr_aer(ll,n,itype,iphase)
  end if
  if (l1 .ge. param_first_scalar) then
      ddvel(it,jt,l1) = vdep_aer(n,itype,iphase)
  end if
     end do
 end do
 end do
 end do
2910 continue
2920 continue
 return
 end subroutine mosaic_drydep_driver
 subroutine mosaic_drydep_1clm( idiagaa, it, jt, &
  ustar_in, depresist_a_in, vdep_aer )
 use module_configure, only: grid_config_rec_type
 use module_data_mosaic_asect
 use module_data_mosaic_other
 use module_mosaic_driver, only: mapaer_tofrom_host
 use module_peg_util, only: peg_error_fatal
 implicit none
 integer, intent(in) :: idiagaa, it, jt
 real, intent(in) :: ustar_in
 real, intent(in) :: depresist_a_in
 real, intent(inout) :: vdep_aer(maxd_asize,maxd_atype,maxd_aphase)
 real, parameter :: densdefault = 2.0
 real, parameter :: smallmassaa = 1.0e-20
 real, parameter :: smallmassbb = 1.0e-30
 real, parameter :: piover6 = pi/6.0
 real, parameter :: onethird = 1.0/3.0
 integer iphase, itype, k, ll, l1, m, n
 real airdens, airkinvisc
 real depresist_a, depresist_unstabpblfact
 real depresist_d0, depresist_d3
 real depvel_a0, depvel_a3
 real drydens, drydp, drymass, dryvol
 real dum, dumalnsg, dumfact, dummass
 real freepath
 real rnum
 real temp
 real ustar
 real vsettl_0, vsettl_3
 real wetdgnum, wetdens, wetdp, wetmass, wetvol
 k = 1
 m = 1
 temp = rsub(ktemp,k,m)
 airdens = cairclm(1)*28.966
 airkinvisc = ( 1.8325e-4 * (416.16/(temp+120.0)) * &
          ((temp/296.16)**1.5) ) / airdens
 freepath = 7.39758e-4 * airkinvisc / sqrt(temp)
 ustar = ustar_in * 100.0
 depresist_a = depresist_a_in * 0.01
 depresist_unstabpblfact = 1.0
 vdep_aer(:,:,:) = 0.0
 iphase = ai_phase
 do 2900 itype = 1, ntype_aer
 do 2800 n = 1, nsize_aer(itype)
 dryvol = 0.0
 drymass = 0.0
 do ll = 1, ncomp_aer(itype)
     l1 = massptr_aer(ll,n,itype,iphase)
     dummass = rsub(l1,k,m)*mw_aer(ll,itype)
     drymass = drymass + dummass
     dryvol = dryvol + dummass/dens_aer(ll,itype)
 end do
 l1 = waterptr_aer(n,itype)
 dummass = rsub(l1,k,m)*mw_water_aer
 wetmass = drymass + dummass
 wetvol = dryvol + dummass/dens_water_aer
 l1 = numptr_aer(n,itype,iphase)
 rnum = rsub(l1,k,m)
 if (drymass .le. smallmassbb) then
     drydp = dcen_sect(n,itype)
     drydens = densdefault
     wetdp = drydp
     wetdens = drydens
     goto 1900
 end if
 if (drymass .le. smallmassaa) then
     wetmass = drymass
     wetvol = dryvol
 end if
 drydens = drymass/dryvol
 wetdens = wetmass/wetvol
 if (rnum .ge. dryvol/volumlo_sect(n,itype)) then
     drydp = dlo_sect(n,itype)
 else if (rnum .le. dryvol/volumhi_sect(n,itype)) then
     drydp = dhi_sect(n,itype)
 else
     drydp = (dryvol/(piover6*rnum))**onethird
 end if
        if(abs(wetvol).gt.(1000.*abs(dryvol))) then
          dumfact=10.0
        else
          dumfact=abs(wetvol/dryvol)**onethird
          dumfact=max(1.0,min(dumfact,10.0))
        endif
 wetdp = drydp*dumfact
1900 continue
 dumalnsg = log( 1.0 )
 wetdgnum = wetdp * exp( -1.5*dumalnsg*dumalnsg )
 call aerosol_depvel_2( &
           wetdgnum, dumalnsg, wetdens, &
           temp, airdens, airkinvisc, freepath, &
           ustar, depresist_unstabpblfact, &
           depresist_d0, vsettl_0, &
           depresist_d3, vsettl_3 )
 dum = depresist_a + depresist_d3 + &
            depresist_a*depresist_d3*vsettl_3
 depvel_a3 = vsettl_3 + (1./dum)
 dum = depresist_a + depresist_d0 + &
            depresist_a*depresist_d0*vsettl_0
 depvel_a0 = vsettl_0 + (1./dum)
 vdep_aer(n,itype,iphase) = depvel_a3 * 0.01
 if (idiagaa>0) print 9310, it, jt, n, itype, iphase, &
  dcen_sect(n,itype), drydp, wetdp, &
  drydens, wetdens, vdep_aer(n,itype,iphase), &
  vsettl_3, depresist_d3, depresist_a
9310 format( 'aerdep', 2i4, 3i3, 1p, 3e10.2, &
  2x, 0p, 2f5.2, 2x, 1p, 4e10.2 )
2800 continue
2900 continue
 return
 end subroutine mosaic_drydep_1clm
 subroutine aerosol_depvel_2( &
           dgnum, alnsg, aerodens, &
           temp, airdens, airkinvisc, freepath, &
           ustar, depresist_unstabpblfact, &
           depresist_d0, vsettl_0, &
           depresist_d3, vsettl_3 )
 implicit none
 real dgnum, alnsg, aerodens, &
           temp, airdens, airkinvisc, freepath, &
           ustar, depresist_unstabpblfact, &
           depresist_d0, vsettl_0, &
           depresist_d3, vsettl_3
 real aerodiffus_0, schmidt_0, stokes_0, facdepresist_d0
 real aerodiffus_3, schmidt_3, stokes_3, facdepresist_d3
 common / aerosol_depvel_cmn01 / &
        aerodiffus_0, schmidt_0, stokes_0, facdepresist_d0, &
        aerodiffus_3, schmidt_3, stokes_3, facdepresist_d3
 real xknudsen, xknudsenfact, alnsg2, duma, dumb, &
       vsettl_dgnum, aerodiffus_dgnum
 real pi
 parameter (pi = 3.1415926536)
 real gravity
 parameter (gravity = 980.616)
 real boltzmann
 parameter (boltzmann = 1.3807e-16)
 xknudsen = 2.*freepath/dgnum
 xknudsenfact = xknudsen*1.246
 alnsg2 = alnsg*alnsg
 vsettl_dgnum = (gravity*aerodens*dgnum*dgnum)/ &
        (18.*airkinvisc*airdens)
 vsettl_0 = vsettl_dgnum * &
        ( exp(2.*alnsg2) + xknudsenfact*exp(0.5*alnsg2) )
 vsettl_3 = vsettl_dgnum * &
        ( exp(8.*alnsg2) + xknudsenfact*exp(3.5*alnsg2) )
 aerodiffus_dgnum = (boltzmann*temp)/ &
        (3.*pi*airkinvisc*airdens*dgnum)
 aerodiffus_0 = aerodiffus_dgnum * &
        ( exp(+0.5*alnsg2) + xknudsenfact*exp(+2.*alnsg2) )
 aerodiffus_3 = aerodiffus_dgnum * &
        ( exp(-2.5*alnsg2) + xknudsenfact*exp(-4.*alnsg2) )
 schmidt_0 = airkinvisc/aerodiffus_0
 schmidt_3 = airkinvisc/aerodiffus_3
 stokes_0 = ustar*ustar*vsettl_0/(gravity*airkinvisc)
 stokes_3 = ustar*ustar*vsettl_3/(gravity*airkinvisc)
 duma = (schmidt_0**(-0.66666666)) + &
        (10.**(-3./max(0.03,stokes_0)))
 dumb = duma*ustar*depresist_unstabpblfact
 depresist_d0 = 1./max( dumb, 1.e-20 )
 facdepresist_d0 = duma
 duma = (schmidt_3**(-0.66666666)) + &
        (10.**(-3./max(0.03,stokes_3)))
 dumb = duma*ustar*depresist_unstabpblfact
 depresist_d3 = 1./max( dumb, 1.e-20 )
 facdepresist_d3 = duma
 return
 end subroutine aerosol_depvel_2
 end module module_mosaic_drydep


!***********************************************************************
!                                                                      *
      SUBROUTINE MATRIX(dvdfirst)
!                                                                      *
!   Calls routines to form the Hamiltonian matrix and to diagonalise   *
!   it. The total angular momenta and parity of each  ASF  is found;   *
!   the eigenvectors are normalised so  that the sign of the largest   *
!   element is positive.                                               *
!                                                                      *
!   Call(s) to: [LIB92] ALLOC, DALLOC.                                 *
!               [RSCF92]: SETHAM, HMOUT.                               *
!               [BLAS]: DCOPY/SCOPY, DSCAL/SSCAL                       *
!                                                                      *
!                                         Last revision: 24 Dec 1992   *
! Block version by Xinghong He                           07 Aug 1998   *
!   Midified by G. Gaigalas                              05 Feb 2017   *
!      It was deleted the arrays:  JQSA(3*NNNW*NCF),                   *
!                                  JCUPA(NNNW*NCF)                     *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  16:52:04   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE memory_man
      USE damp_C
      USE def_C,           ONLY: iccmin, ncmin, ncmax
      USE DEBUG_C
      USE eigv_C
      USE hblock_C
      USE hmat_C
      USE iounit_C
      USE MCPA_C
      USE mpi_s
      USE orb_C
      USE pos_C
      USE peav_C
      USE syma_C,          ONLY: JPGG
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE setham_I
      USE maneig_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      logical, INTENT(IN) ::  dvdfirst
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NFILE, NELEC, NTMP, JBLOCK, JBLOCKT, I, NCFPAT, NCMINPAT, &
         NEVECPAT, NCFT, NCOEFF, LAB, NCONTR, ITMP, IR, IDIAG, J, IOFSET, &
         JOTHER, IA, JOFSET, IATTMP, IASTMP, NELMNTGG
      REAL(DOUBLE), DIMENSION(:), POINTER :: CMVL
      REAL(DOUBLE) :: amax, cdampj, dnfac, evecij, sum,  tmp, omcdaj, ovrlap, wa
      INTEGER, EXTERNAL :: ddot
      LOGICAL :: FIRST
      CHARACTER :: MCPLAB*3

      SAVE FIRST
!
      DATA FIRST/ .TRUE./
!
!     POINTER (cmvl(1))
!
!-----------------------------------------------------------------------

      IF (MYID == 0) WRITE (6, *)

!   Allocate memory for CMVL once (the maximum size)
!   Save previous estimate of eigenvectors

      IF (.NOT.FIRST) THEN
         CALL ALLOC (CMVL, NVECSIZ, 'CMVL', 'MATRIX')
         CALL DCOPY (NVECSIZ, EVEC, 1, CMVL, 1)
      ENDIF

!=======================================================================
!   Position the files - MCP files (unit NFILE) for reading
!   and mixing coefficients file (unit 25) for writing
!=======================================================================

      DO NFILE = 30, 32 + KMAXF
         REWIND (NFILE)
         IF (NFILE == 30) THEN
            READ (NFILE)
            READ (NFILE)
            READ (NFILE)
         ENDIF
         READ (NFILE)
         READ (NFILE)
         READ (NFILE)
      END DO

      ! To put in ncmin and nvecsiz. Values read here are the same
      ! as those from elsewhere (shch as common blocks)
      IF (MYID == 0) THEN
         REWIND (25)
         READ (25)                               ! 'G92MIX'
         READ (25) NELEC, NCFTOT, NW, NTMP, NTMP, NBLOCK
         BACKSPACE (25)
         WRITE (25) NELEC, NCFTOT, NW, NCMIN, NVECSIZ, NBLOCK
      ENDIF

!=======================================================================
!   Do the job block by block
!=======================================================================

               !------------------------------------------------
      DO JBLOCK = 1, NBLOCK                      ! block do-loop
               !------------------------------------------------

!=======================================================================
!   Read indeces of non-zero elements from mcp.30 file. Note the
!   format has been changed to lower-triangle-by-rows.
! Length of iendc can be reduced
!=======================================================================

         READ (30) MCPLAB, JBLOCKT, NCF
         IF (JBLOCKT/=JBLOCK .OR. NCF/=NCFBLK(JBLOCK)) ERROR STOP &
            'matrx: jblockt .NE. jblock .OR. ncf1 .NE. ncf2'
         READ (30) NELMNTGG
         NELMNT = INT8(NELMNTGG)
         CALL ALLOC (IROW, NELMNT, 'IROW', 'MATRIX')
         CALL ALLOC (EMT, NELMNT, 'EMT', 'MATRIX')
!cjb          ALLOC (IENDC, NCF + 1,...)  ->  ALLOC (IENDC, 0, NCF,...)
!cjb     CALL ALLOC (IENDC, NCF + 1, 'IENDC', 'MATRIX' )
         CALL ALLOC (IENDC, 0, NCF, 'IENDC', 'MATRIX' )

!        ! may not be necessary if iendc is ALWAYS used
         IENDC(0:NCF) = 0                        ! the way it is assigned here.

      !...EMT will be accumulated in setham
         EMT(:NELMNT) = 0.D0

         READ (30) (IENDC(I),I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT)

         NCFPAT = NCFPAST(JBLOCK)
         NCMINPAT = NCMINPAST(JBLOCK)
         NEVECPAT = NEVECPAST(JBLOCK)

!=======================================================================
!   Skip current block if no eigenlaue is required
!=======================================================================

         IF (NEVBLK(JBLOCK) == 0) THEN
            DO NFILE = 31, 32 + KMAXF
               READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF
               IF (JBLOCKT /= JBLOCK) ERROR STOP 'matrx: jblockt .NE. jblock'
               IF (NCFT /= NCF) ERROR STOP 'matrx: ncft .NE. ncf'

               READ (NFILE) LAB, NCONTR
               DO WHILE(LAB/=0 .OR. NCONTR/=0)
                  READ (NFILE) (ITMP,ITMP,TMP,I=1,NCONTR)
                  READ (NFILE) LAB, NCONTR
               END DO
            END DO

            CALL DALLOC (IENDC, 'IENDC', 'MATRIX')
            CALL DALLOC (IROW, 'IROW', 'MATRIX')

            CYCLE

         ENDIF

!=======================================================================
!   Generate the Hamiltonian matrix - average energy is removed here
!=======================================================================

         CALL SETHAM (JBLOCK, MYID, NPROCS)
!
!   Determine average energy
!
         EAV = 0.D0
         DO IR = myid + 1, ncf, nprocs
            EAV = EAV + EMT(IENDC(IR))
         END DO
!         DO IR = 1, (NCF - (MYID + 1) + NPROCS)/NPROCS
!            EAV = EAV + EMT(IENDC(NPROCS*(IR-1)+MYID+1))
!         END DO

         EAV = EAV/NCF
         EAVBLK(JBLOCK) = EAV

      ! Print Hamiltonian matrix and average energy
      ! hmout is not general
      !call hmout (0, 1, ncf)

         IF (MYID == 0) WRITE (*, 302) EAV

      ! Subtract the average energy from the diagonal elements
      ! to reduce the condition number of the matrix
!         DO I = 1, (NCF - (MYID + 1) + NPROCS)/NPROCS
!            EMT(IENDC(NPROCS*(I-1)+MYID+1)) = EMT(IENDC(NPROCS*(I-1)+MYID+1))&
!                - EAV
         DO i = myid + 1, ncf, nprocs
            idiag = iendc(i)     ! new mode: each row ends in diagonal
            emt(idiag) = emt(idiag) - eav
         END DO

!=======================================================================
!   Compute and store eigenpairs
!=======================================================================

         CALL MANEIG (dvdfirst, LDBPG(3),                      &
                   JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT)

!=======================================================================
!   Damp and Schmidt orthogonalise eigenvectors for OL calculations
!=======================================================================

         IF (.NOT.FIRST) THEN

            DO J = 1, NEVBLK(JBLOCK)

               IOFSET = (J - 1)*NCF + NEVECPAT
               JOTHER = J

            ! cdamp has the original non-block feature
               CDAMPJ = CDAMP(J + NCMINPAT)
               IF (CDAMPJ == 0.D0) CYCLE         ! So SURE ???

               OMCDAJ = 1.D0 - CDAMPJ

           !...Damp eigenvector and determine the new dominant component
  123          CONTINUE
               AMAX = 0.D0
               DO I = 1, NCF
                  EVECIJ = OMCDAJ*EVEC(I+IOFSET) + CDAMPJ*CMVL(I + IOFSET)
                  EVEC(I+IOFSET) = EVECIJ
                  WA = ABS(EVECIJ)
                  IF (WA <= AMAX) CYCLE
                  AMAX = WA
                  IA = I
               END DO

            !...compute the normalization factor
               SUM = 0.D0
               DO I = 1, NCF
                  SUM = SUM + EVEC(I+IOFSET)**2
               END DO
               DNFAC = 1.D0/SQRT(SUM)

            !...Renormalize and invert as necessary
               IF (EVEC(IA+IOFSET) < 0.D0) DNFAC = -DNFAC
               CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1)

            !...Schmidt orthogonalise
  234          CONTINUE
               JOTHER = JOTHER - 1
               IF (JOTHER < 1) CYCLE
               JOFSET = (JOTHER - 1)*NCF + NEVECPAT
               OVRLAP = DDOT(NCF,EVEC(IOFSET+1),1,EVEC(JOFSET+1),1)
               IF (OVRLAP /= 0.D0) THEN          ! So SURE ???
                  OMCDAJ = 1.D0
                  CDAMPJ = -OVRLAP
                  CALL DCOPY (NCF, EVEC(JOFSET+1), 1, CMVL(IOFSET + 1), 1)
                  GO TO 123
               ELSE
                  GO TO 234
               ENDIF
            END DO
         ENDIF

!   Write out the eigenpair information: ASF symmetries, eigenvalues,
!   and eigenvectors to GRASP92 mixing coefficients File

         IF (NEVBLK(JBLOCK) == 0) THEN
            IATTMP = 999
            IASTMP = 999
         ELSE
!GGGG
            iattmp = IABS(JPGG(jblock))
            IF(JPGG(jblock) >= 0) THEN
!cjb iastmp error corrected by Pawel Syty
!PS            iastmp = 2
               iastmp = 1
            ELSE
!cjb iastmp error corrected by Pawel Syty
!PS            iastmp = 1
               iastmp = -1
            END IF
!GG            IATTMP = IATJPO(NCMINPAT + 1)
!GG            IASTMP = IASPAR(NCMINPAT + 1)
         ENDIF

         IF (MYID == 0) THEN
            WRITE (25) JBLOCK, NCF, NEVBLK(JBLOCK), IATTMP, IASTMP
            WRITE (25) (ICCMIN(I + NCMINPAT),I=1,NEVBLK(JBLOCK))
            WRITE (25) EAV, (EVAL(I + NCMINPAT),I=1,NEVBLK(JBLOCK))
            WRITE (25) ((EVEC(I+(J-1)*NCF+NEVECPAT),I=1,NCF),J=1,NEVBLK(JBLOCK)&
               )
         ENDIF

         CALL DALLOC (EMT, 'EMT', 'MATRIX')
         CALL DALLOC (IENDC, 'IENDC', 'MATRIX')
         CALL DALLOC (IROW, 'IROW', 'MATRIX')

!----------------------
      END DO
!----------------------
!
!   Deallocate the temporary storage
!
      IF (.NOT.FIRST) THEN
         CALL DALLOC (CMVL, 'CMVL', 'MATRIX')
      ELSE
         FIRST = .FALSE.
      ENDIF

  302 FORMAT(' Average energy = ',1P,D18.10,' Hartrees')

      RETURN
      END SUBROUTINE MATRIX