MODULE BEHAVIOR_MOD

! The behavior module is used to assign biological or physical characteristics
!   to particles.
! Currently particle movement is in the vertical direction.
!
! Particle characteristics can include a swimming/sinking speed component and
! a behavioral cue component that can depend upon particle age. The swimming/
! sinking speed component controls the speed of particle motion and can be
! constant or set with a function. The behavioral cue component regulates the
! direction of particle movement. For biological behaviors, a random component
! is added to the swimming speed and direction to simulate random variation in
! the movements of individuals (in behavior types 1 - 5, see list below).
! Physical characteristics can also be assigned to particles, like constant
! sinking velocity, without the additional random movements (behavior type 6).
! The following behavior types are currently available in LTRANS and are
! specified using the Behavior parameter in the LTRANS.inc file:
!
!
! Passive (no behavior): Behavior = 0. In this case, the behavior module is not
!   executed. Particle motion is based on advection, and, if turned on,
!   horizontal and vertical turbulence.
!
! Near-surface orientation: Behavior = 1. Particles swim up if they are deeper
!   than 1 m from the surface.
!
! Near-bottom orientation: Behavior = 2. Particles swim down if they are
!   shallower than 1 m from the bottom.
!
! Diurnal vertical migration: Behavior = 3. Particles swim down if light levels
!   at the particle location exceed a predefined threshold value.
!
! Crassostrea virginica oyster larvae: Behavior = 4. Swimming speeds and
!   direction of motion vary depending upon age (stage) according to field and
!   laboratory observations (see North et al. 2008).
!
! C. ariakensis oyster larvae: Behavior = 5. Swimming speeds and direction of
!   motion vary depending upon age (stage) according to field and laboratory
!   observations (see North et al. 2008).
!
! Sinking velocity: Behavior = 6. Particles move up or down with constant
!   sinking (or floating) speeds without individual random motion. Code that
!   calculates salinity and temperature at the particle location is included
!   (but commented out) as a basis for calculating density-dependent sinking
!   velocities.
!
! Tidal Stream Transport: Behavior = 7.
!
!
! Behavior algorithms and code created by: Elizabeth North
! Module structure created by:             Zachary Schlag
! Created on:                              2004
! Last Modified on:                        22 March 2011
!

  IMPLICIT NONE
  PRIVATE
  SAVE

  !Timer for C. ariakensis downward swimming behavior
  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: timer

  !Behavior of each particle
  INTEGER, ALLOCATABLE, DIMENSION(:) :: P_behave

  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:  ) ::    &
    P_pediage, & !Age at which the particle will settle (become a pediveliger)
    P_deadage, & !Age at which the particle will stop moving (die)
      !The following are for calculating salt gradient:
    P_Sprev,   & !Salinity at particle's previous location
    P_zprev      !Particle's previous depth

  !Swimming speed (age-dependent, linear increase unless constant)
  !(n,1)slope, (n,2)intercept, (n,3) speed at current age
  DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: P_swim

  !For behavior 7, tracks if particle is on the bottom
  LOGICAL, ALLOCATABLE, DIMENSION(:) :: bottom

  !Tracks if the particle is dead (TRUE) or alive (FALSE)
  LOGICAL, ALLOCATABLE, DIMENSION(:) :: dead

  !Tracks if particles are Out Of Bounds (ie cross open ocean bound)
  LOGICAL, ALLOCATABLE, DIMENSION(:) :: oob

  !The following procedures have been made public:
  PUBLIC :: initBehave,updateStatus,behave,getStatus,finBehave, &
            setOut,isOut,die,isDead

CONTAINS

  SUBROUTINE initBehave()    !Initialize the behavior module
    USE PARAM_MOD, ONLY: numpar,Behavior,swimfast,swimslow,swimstart,     &
                         pediage,deadage,Sgradient,settlementon
    USE SETTLEMENT_MOD, ONLY: initSettlement
    USE NORM_MOD,   ONLY: norm
    IMPLICIT NONE
    INTEGER :: n

    write(*,*) 'initialize behavior'

    !Allocate Behavior Variables
    ALLOCATE(timer(numpar))
    ALLOCATE(P_behave(numpar))
    ALLOCATE(P_pediage(numpar))
    ALLOCATE(P_deadage(numpar))
    ALLOCATE(P_Sprev(numpar))
    ALLOCATE(P_zprev(numpar))
    ALLOCATE(P_swim(numpar,3))
    ALLOCATE(dead(numpar))
    ALLOCATE(oob(numpar))

    IF(Behavior == 7) THEN
      ALLOCATE(bottom(numpar))
      bottom = .TRUE.
    ENDIF

    do n=1,numpar
      !Set behavior to the one specified in LTRANS.inc
      P_behave(n) = Behavior  !Behavior
      P_pediage(n) = pediage  !age at which particle reaches maximum swimming
                              !speed and can settle (becomes a pediveliger) (s)
      P_deadage(n) = deadage  !age at which particle stops moving (dies) (s)
      !Note: the following code assigns different veliger and pediveliger
      !  stage durations
      !P_pediage(n) = (14. + norm()*0.5)*24.*3600.
      !P_deadage(n) = P_pediage(n) + (7. + norm()*0.5)*24.*3600.

      !Calculate slope and intercept for age-dependent linear swimming speed
      P_swim(n,1) = (swimfast - swimslow)/(P_pediage(n) - swimstart) !slope
      P_swim(n,2) = swimfast - P_swim(n,1)*P_pediage(n)              !intercept
      P_swim(n,3) = 0.0                                   !swimming speed (m/s)
      !Note: P_swim(n,3) is updated at each time step in Subroutine behave
    enddo

    !The following variables are used by the C. virginica and C. ariakensis
    !  behavior routines
    timer = DBLE(0.0)         !to count how long C. arikensis particles swim down

    ! Initialize salt storage matrices
    P_Sprev = 0.0       !Initialized to 0.0
    P_zprev = 0.0       !Initialized to 0.0

    ! Initialize dead to .FALSE. i.e. all particles are initially alive
    dead = .FALSE.

    ! Initialize out of bounds tracker to .FALSE.
    !   (i.e. all particles start in bounds)
    oob = .FALSE.

    !if Settlement is turned on then inform Settlement module of the age at
    !  which particle can settle (i.e., become pediveligers)
    if(settlementon)then
      CALL initSettlement(P_pediage)
    endif

  END SUBROUTINE initBehave

  SUBROUTINE updateStatus(P_age,n)  !Update particle status
    USE SETTLEMENT_MOD, ONLY: isSettled
    USE PARAM_MOD, ONLY: settlementon,mortality
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: n
    DOUBLE PRECISION, INTENT(IN) :: P_age

    !Determine if particle dies from old age, if so kill it
    if ((P_age .GE. P_deadage(n)) .AND. mortality) then
      if(settlementon)then
        if(.NOT. isSettled(n)) call die(n)
      else
        call die(n)
      endif
    endif

  END SUBROUTINE updateStatus

  SUBROUTINE behave(Xpar,Ypar,Zpar,Pwc_zb,Pwc_zc,Pwc_zf,P_zb,P_zc,P_zf,        &
                    P_zetac,P_age,P_depth,P_U,P_V,P_angle,n,it,ex,ix,          &
                    daytime,p,bott,XBehav,YBehav,ZBehav)
    USE PARAM_MOD, ONLY: us,dt,idt,twistart,twiend,Em,pi,daylength,Kd,thresh,  &
                         Sgradient,swimfast,swimstart,sink,Hswimspeed,         &
                         Swimdepth
    USE HYDRO_MOD, ONLY: WCTS_ITPI
    USE RANDOM_MOD, ONLY: genrand_real1
    IMPLICIT NONE

    DOUBLE PRECISION, INTENT(IN) :: daytime
    DOUBLE PRECISION, INTENT(IN) :: Xpar,Ypar,Zpar,Pwc_zb(:),Pwc_zc(:),        &
                                    Pwc_zf(:),P_zb,P_zc,P_zf,P_zetac,P_age,    &
                                    P_depth,P_U,P_V,P_angle,ex(3),ix(3)
    INTEGER, INTENT(IN) :: n,it,p
    LOGICAL, INTENT(OUT) :: bott
    DOUBLE PRECISION, INTENT(OUT) :: XBehav,YBehav,ZBehav

    INTEGER :: btest,i,deplvl
    DOUBLE PRECISION :: negpos,dev1,devB,switch,switchslope
    DOUBLE PRECISION :: P_S,parBehav,Sslope,deltaS,deltaz
    ! DOUBLE PRECISION :: P_T !not needed unless temperature code below is enabled
    DOUBLE PRECISION :: dtime,tst,E0,P_light
    DOUBLE PRECISION :: currentspeed,Hdistance,theta,X,Y

    !   ***************** Initialize Return Values
    XBehav = 0.0
    YBehav = 0.0
    ZBehav = 0.0

    !   ***************** Update vertical swimming speeds based on particle age

    if(P_age .GE. swimstart) P_swim(n,3) = P_swim(n,1)*P_age+P_swim(n,2)
    if(P_age .GE. P_pediage(n)) P_swim(n,3) = swimfast

    !   ***************** Prepare for TYPE 4 & 5 (Oyster Larvae) Behaviors

    !Update pediveliger behavior/status and timer
    IF(P_behave(n) .EQ. 4 .OR. P_behave(n) .EQ. 5) THEN

      !Set behavior code for pediveligers
      if (P_age .GE. P_pediage(n) .AND. P_age .LT. P_deadage(n)) then
        P_behave(n) = 2
      endif

      !decrement timer
      timer(n) = max(DBLE(0.0), timer(n)-DBLE(dt))
    ENDIF

    !obtain salinity at particle location (P_S) to cue oyster larvae or tidal
    !  stream transport behavior
    IF ((P_behave(n).EQ.4) .OR. (P_behave(n).EQ.5 .AND. timer(n).EQ.0.0) .OR.  &
         P_behave(n).EQ.7) THEN

      do i=3,us-2
        if ((Zpar .LT. Pwc_zb(i)) .OR. (Zpar .LT. Pwc_zc(i)) .OR.              &
            (Zpar .LT. Pwc_zf(i))) exit
      enddo
      deplvl = i-2   !depth level

      !Salinity at particle location
      P_S = WCTS_ITPI("salt",Xpar,Ypar,deplvl,Pwc_zb,Pwc_zc,Pwc_zf,us,P_zb,    &
                      P_zc,P_zf,ex,ix,p,4)

    ENDIF

    !           *********************************************************
    !           *                                                       *
    !           *                   Behaviors                           *
    !           *                                                       *
    !           *********************************************************

    parBehav = 0.0

    !TYPE 1. Surface oriented. Particle swims up if deeper than 1 m.
    IF (P_behave(n).EQ.1) THEN
       btest = 0   !switch to control behavior

       !particle has 80% chance of swimming up if deeper than 1.0 m of bottom
       if (P_zc .LT. (P_zetac-1.0)) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.80
          if (dev1.GT.switch) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
          btest = 1
       end if

       !if within 1 m of surface, swim randomly (50% chance of swimming up)
       if (btest.EQ.0) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.5
          if (dev1.GT.switch) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
       end if

    END IF

    !TYPE 2. Near-bottom. Particle swim down if not within 1 m of bottom.
    IF (P_behave(n).EQ.2 .OR. (P_behave(n).EQ.5 .AND. timer(n).GT.0.0)) THEN
       btest = 0   !switch to control behavior

       !particle has 80% change of swimming down if greater than 1.0 m
       !  from bottom
       if (P_zc .GT. (P_depth+1.0)) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.20
          if (dev1.GT.switch) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
          btest = 1
       end if

       !if within 1 m of bottom, just swim randomly
       if (btest.EQ.0) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.5
          if (dev1.GT.switch) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
       end if

    END IF

    !TYPE 3: Diurnal Vertical Migration
    IF (P_behave(n).EQ.3) THEN

       !A. Find daytime in hrs since midnight (dtime)
       dtime = (daytime - aint(daytime))*DBLE(24.0)  !time of day
       !This assumes that model simulations start at midnight

       !B. Calcluate irradiance at the water's surface (E0)
       tst = 0.0  !seconds since twilight start
       E0 = 0.0   !irradiance at the water's surface
       if (dtime.GT.twiStart .AND. dtime.LT.twiEnd) then
          tst=(dtime-twiStart)*DBLE(3600.0)
          E0= Em*SIN(PI*tst/(daylength*DBLE(3600.0)))*     &
                 SIN(PI*tst/(daylength*DBLE(3600.0)))
       else
          E0 = 0.0
       end if

       !C. Calcluate irradiance at depth of the particle
       P_light = E0 * exp(Kd*P_zc)

       !If light at particle location is less than threshold, random swimming
       if (P_light.LT.thresh ) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.5
          if (dev1.GT.switch) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
       end if
       !If light at particle > threshold, then have 80% chance of swimming down
       if (P_light.GT.thresh ) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.20
          if (dev1.GT.switch) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
       end if

    END IF

    !TYPE 4. Crassostrea virginica -- above the halocline
    IF (P_behave(n).EQ.4) THEN
       if (it.EQ.1) then
          P_Sprev(n) = P_S  !for first iteration
          P_zprev(n) = P_zc
       endif
       btest = 0   !switch to control behavior
       Sslope = 0.0  !salinity gradient that larvae swam through

       !determine if larva swam through salinity gradient large enough to
       !  cue behavior;  if so, then 80% chance of swimming up
       deltaS = P_Sprev(n) - P_S
       deltaz = P_zprev(n) - P_zc
       if (it.GT.1) Sslope = deltaS/deltaz
       if (abs(Sslope).GT.Sgradient) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.80
          if (dev1.GT.switch) negpos = -1.0
          parBehav=negpos*P_swim(n,3)
          btest = 1
       endif

       !if no directed swimming, swim randomly with probabilities that result
       !  in particles moving up initially, then slowly moving toward bottom
       !  with increasing age
       if (btest.EQ.0) then
          negpos = 1.0
          dev1=genrand_real1()
          if (P_age .LT. 1.5*24.*3600.) then     !if Age < 1.5 Days
            switch = 0.1
          elseif (P_age .LT. 5.*24.*3600.) then  !if 1.5 Days <= Age < 5.0 Days
            switch = 0.49
          elseif (P_age .LT. 8.*24.*3600.) then  !if 5.0 Days <= Age < 8.0 Days
            switch = 0.50
          else                                   !if Age >= 8.0 Days
             switchslope = (DBLE(0.50)-DBLE(0.517)) /                          &
                           (DBLE(8.0)*DBLE(24.0)*DBLE(3600.0) - P_pediage(n))
             switch = switchslope*P_age + DBLE(0.50) -                         &
                      switchslope*DBLE(8.0)*DBLE(24.0)*DBLE(3600.0)
             if (P_zc .LT. P_depth+1.) switch = 0.5
          endif
          if (dev1.GT.(1-switch)) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
       endif

       !update previous salt and depth matrix for next iteration
       P_Sprev(n) = P_S
       P_zprev(n) = P_zc
    ENDIF

    !TYPE 5. Crassostrea ariakensis -- below the halocline
    IF (P_behave(n).EQ.5 .AND. timer(n).EQ.0.0) THEN
       if (it.EQ.1) then
          P_Sprev(n) = P_S  !for first iteration
          P_zprev(n) = P_zc
       endif
       btest = 0   !switch to control behavior
       Sslope = 0.0  !salinity gradient that larvae swam through

       !determine if larva swam through salinity gradient large enough to
       !  cue behavior.  If so, then 80% chance of swimming down. Set timer
       !  to keep particle near bottom for 2 hrs
       deltaS = P_Sprev(n) - P_S
       deltaz = P_zprev(n) - P_zc
       if (it.GT.1) Sslope = deltaS/deltaz
       if (abs(Sslope).GT.Sgradient) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.20
          btest = 1
          timer(n) = DBLE(2.0)*DBLE(3600.0)  !2 hr times 3600 s
          if (dev1.GT.switch) negpos = -1.0
          parBehav=negpos*P_swim(n,3)
          !keep bottom oriented behavior from starting until after particle
          !  is 3.5 days old
          if (P_age .LT. 3.5*24.*3600.) then
             btest = 0
             timer(n) = 0.
          endif
       endif

       !if no directed swimming, just swim randomly with probabilities that
       !  result in particles moving up initially, then moving toward bottom
       !  with increasing age
       if (btest.EQ.0) then
          negpos = 1.0
          dev1=genrand_real1()
          switch = 0.495
          if (P_age .LT. 1.5*24.*3600.) switch = 0.9
          if (P_age .GT. 2.0*24.*3600. .AND. P_age .LT. 3.5*24.*3600.) then
             switchslope = (DBLE(0.3)-DBLE(0.495)) /                 &
                           (DBLE(2.0)*DBLE(24.0)*DBLE(3600.0) -      &
                            DBLE(3.5)*DBLE(24.0)*DBLE(3600.0))
             switch = switchslope*P_age+DBLE(0.3) -                  &
                      switchslope*DBLE(2.0)*DBLE(24.0)*DBLE(3600.0)
          endif
          if (dev1.GT.switch) negpos = -1.0
          devB=genrand_real1()
          parBehav=negpos*devB*P_swim(n,3)
       endif

       !update previous salt and depth matrix for next iteration
       P_Sprev(n) = P_S
       P_zprev(n) = P_zc
    ENDIF

    !TYPE 6. Constant -- no random motion to vertical movement
    IF ((P_behave(n).EQ.6)) THEN
       if(P_age .GE. swimstart) then
          parBehav = sink
       else
          parBehav = P_swim(n,3)
       endif

       !Note: the code below is included if someone wants to calculate density
       ! ! To calculate salinity (P_S) and temperature (P_T) at particle location
       !  do i=3,us-2
       !    if ((Zpar .LT. Pwc_zb(i)) .OR. (Zpar .LT. Pwc_zc(i)) .OR.     &
       !        (Zpar .LT. Pwc_zf(i))) exit
       !  enddo
       !  deplvl = i-2   !depth level
       !
       !  !Salinity at particle location
       !  P_S = WCTS_ITPI("salt",Xpar,Ypar,deplvl,Pwc_zb,Pwc_zc,Pwc_zf,us,     &
       !                  P_zb,P_zc,P_zf,ex,ix,p,4)
       !
       !  !Temperature at particle location
       !  P_T = WCTS_ITPI("temp",Xpar,Ypar,deplvl,Pwc_zb,Pwc_zc,Pwc_zf,us,     &
       !                  P_zb,P_zc,P_zf,ex,ix,p,4)
    ENDIF

    !Calculate movement due to behavior for all behaviors other than 7
    ZBehav = parBehav * idt

    !TYPE 7. Tidal Stream Transport: if flooding, then swim in direction of
    !  currents, else sit on bottom
    IF ((P_behave(n).EQ.7)) THEN
       ! Set initial values for the first iteration
       if (it.EQ.1) then
          P_Sprev(n) = P_S
          currentspeed = 0.0
       endif
       !Find current speed at the particle location ( c = sqrt(a**2 + b**2) )
       currentspeed = sqrt( (P_U*cos(P_angle) - P_V*sin(P_angle))**2 +         &
                            (P_U*sin(P_angle) + P_V*cos(P_angle))**2 )
       if (bottom(n) .EQV. .TRUE.) then          !CRS
          !if particle is on bottom, test if salinity is increasing
          if (P_Sprev(n).LT.P_S) then       !if salinity is increasing:
             bottom(n) = .FALSE.            !  come off bottom
             ZBehav = P_depth + Swimdepth   !  and swim to the swimming depth
          else
             ZBehav = -9999  !if salinity is not increasing, stay on bottom
          end if
       else
          !if particle is not on bottom, test if currents are not slack
          !  (defined as 0.05 m/s)
          if (currentspeed.GT.0.05) then
             !if the current speed is greater than 0.05 m/s, then swim in the
             !  direction of the current
             Hdistance = Hswimspeed*idt
             !find theta of currents
             theta = atan( (P_U*sin(P_angle) + P_V*cos(P_angle)) /             &
                           (P_U*cos(P_angle) - P_V*sin(P_angle)) )
             X = (P_U*cos(P_angle) - P_V*sin(P_angle))
             Y = (P_U*sin(P_angle) + P_V*cos(P_angle))
             if(X.GT.0.0) then
                XBehav =  Hdistance*cos(theta)
                YBehav =  Hdistance*sin(theta)
             end if
             if(X.LT.0.0) then
                XBehav =  DBLE(-1.0)*Hdistance*cos(theta)
                YBehav =  DBLE(-1.0)*Hdistance*sin(theta)
             end if
             if(X.EQ.0 .AND. Y.GE.0.0) then
                XBehav =  0.0
                YBehav =  Hdistance
             end if
             if(X.EQ.0 .AND. Y.LE.0.0) then
                XBehav =  0.0
                YBehav =  DBLE(-1.0)*Hdistance
             end if
             !keep vertical position of particle at swim depth
             ZBehav = P_depth + Swimdepth
          else
             ZBehav = -9999       !if the current speed is less than 0.05 m/s,
             bottom(n) = .TRUE.   !  then swim to bottom
          end if
       end if
       bott = bottom(n)
    ENDIF

! ******************* End Particle Behavior ******************************
  END SUBROUTINE behave

  INTEGER FUNCTION getStatus(n)
    !This function returns an identification number that describes a particle's
    !behavior type or status for use in visualization routines. It was
    !initially developed to contain the color code for plotting in Surfer.)
    USE PARAM_MOD, ONLY: SETTLEMENTON,OPENOCEANBOUNDARY
    USE SETTLEMENT_MOD, ONLY: isSettled
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n

    getStatus = P_behave(n)          ! Set Status to behavior ID
                                     ! Change if Dead, Settled, or OutOfBounds

    if(dead(n)) getStatus = -1         ! -1 = Dead
    if(settlementon)then
      if(isSettled(n)) getStatus = -2  ! -2 = Settled
    endif
    if(OpenOceanBoundary)then
      if(oob(n)) getStatus = -3        ! -3 = Out of Bounds
    endif

  END FUNCTION getStatus

  LOGICAL FUNCTION isDead(n)
  !This function returns .TRUE. if the particle is "dead", and FALSE if not
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n

    isDead = dead(n)

  END FUNCTION isDead

  SUBROUTINE die(n)
  !This subroutine sets the value of dead(n) to TRUE, indicating
  !  the particle is "dead"
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n

    dead(n) = .TRUE.

  END SUBROUTINE die

  SUBROUTINE setOut(n)
    !This subroutine changes particle n's status to out of bounds
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n

    oob(n) = .TRUE.

  END SUBROUTINE setOut

  LOGICAL FUNCTION isOut(n)
    !This function returns the value of oob for particle n
    ! i.e. Returns True if the particle is out of bounds, False if in bounds
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n

    isOut = oob(n)

  END FUNCTION isOut

  SUBROUTINE finBehave()    !Finish the behavior module
  USE PARAM_MOD     , ONLY: settlementon
  USE SETTLEMENT_MOD, ONLY: finSettlement
  IMPLICIT NONE

    !Deallocate Behavior Variables
    DEALLOCATE(timer)
    DEALLOCATE(P_behave)
    DEALLOCATE(P_pediage)
    DEALLOCATE(P_deadage)
    DEALLOCATE(P_Sprev)
    DEALLOCATE(P_zprev)
    DEALLOCATE(P_swim)
    DEALLOCATE(dead)
    DEALLOCATE(oob)

    if(ALLOCATED(bottom))DEALLOCATE(bottom)

    !If Settlement is on, Deallocate Settlement Variables
    if(settlementon) call finSettlement()

  END SUBROUTINE finBehave

END MODULE BEHAVIOR_MOD


      SUBROUTINE hamiltonian( deltae, number,
     $     H_aux, n_aux, Nc_aux, k_in, skparameters  )
c
c     hamiltonian of a silicon nanowire
c
      implicit none

c     passed parameters
      double precision deltae, skparameters(18)
      integer number, n_aux, Nc_aux
      double precision H_aux((Nc_aux*n_aux)*
     $     ((Nc_aux*n_aux+1)/2)*(2+100))

      integer nlay,natol, k_in
c     maximum number of layers, maximum number of atoms per layer
      parameter(nlay=50,natol=20)
      integer i,j,nat,nla,nalayer(nlay),nl,natom,ty(nlay,natol),
     #up1(nlay,natol),up2(nlay,natol),tup1(nlay,natol),
     #tup2(nlay,natol),do1(nlay,natol),do2(nlay,natol),
     #tdo1(nlay,natol),tdo2(nlay,natol),
     #prev,prevorb(nlay,natol),norb(nlay),i1,j1,prorbl(nlay),nat1,
     #num1,num2,num1a,num1o,num2a,num2o,napre5,na(nlay,natol),pr,pr1,
     #prorbl1(nlay),nna,nna1,narid(nlay*natol),naext(nlay*natol),
     #nalamax,ordh,norbh(4),na1,na2,rem,nc,preorbla(4),pre,pre1,
     #ll,snumk,info,ordh1,ordhe,ordhe1,preorblae(4)
      double precision es,ep,ew,ed,ss1,ww1,sw1,sp1,wp1,sd1,wd1,
     #pp1,pp2,pd1,pd2,dd1,dd2,dd3,l,m,n,
     #q,pot(nlay,natol),diag(nlay,natol*10,natol*10),
c     #subdiag(nlay-1,natol*10,natol*10),
     #superdiag(nlay-1,natol*10,natol*10),val,
     #a,pi,dk,k,en(4*natol*10),val1,val2,rwork(3*4*natol*10)
c     #,hami1((nlay-6)*natol*10,(nlay-6)*natol*10),
c     #hamie1((nlay-6)*natol*10,(nlay-6)*natol*10)
      double complex ui,work(2*4*natol*10)
c     #,hami(4*natol*10,4*natol*10),hamie(4*natol*10,4*natol*10)
      character*14 str1*14,str2*14,str1a*30,str2a*30,
     #str1ae*31,str2ae*31
c
      q=1.60217733d-19
c
      open(unit=10,file='nalayer.dat',status='unknown')
      read(10,*) nat
c     total number of atoms
      read(10,*) nla
c     number of layers
      if (nla.gt.nlay) then
         write(*,*) 'error: nla>nlay !'
         goto 10
      end if
      do i=1,nla
         read(10,*) nalayer(i)
c        number of atoms in each layer
         if (nalayer(i).gt.natol) then
            write(*,*) 'error: nalayer(i)>natol !'
            goto 10
         end if
      end do
      close(10)
      napre5=nalayer(1)+nalayer(2)+nalayer(3)+nalayer(4)
c
      open(unit=11,file='infoatoms.dat',status='unknown')
      do i=1,nat
         read(11,*) nl,natom
         na(nl,natom)=i
         read(11,*) ty(nl,natom)
c        each atom of the nanowire
         read(11,*) up1(nl,natom),tup1(nl,natom)
         read(11,*) up2(nl,natom),tup2(nl,natom)
         read(11,*) do1(nl,natom),tdo1(nl,natom)
         read(11,*) do2(nl,natom),tdo2(nl,natom)
c        its 4 first neighbors
      end do
      close(11)
c
      do i=1,nla
         prev=0
         do j=1,nalayer(i)
            prevorb(i,j)=prev
c           number of atomic orbitals to be considered in the
c           corresponding layer before the specified atom
            prev=prev+10
         end do
         norb(i)=prev
c        total number of atomic orbitals to be considered in each layer
      end do
c
c---------------------------------------------------
c
      nalamax=0
      do i=4,nla-3
         if (nalayer(i).gt.nalamax) then
            nalamax=nalayer(i)
         end if
      end do
c
      open(unit=80,file='nalamax.dat',status='unknown')
      write(80,*) nalamax
      close(80)

      number = nalamax
c
      open(unit=81,file='correspondence.dat',status='unknown')
      nna1=-4*nalamax
      nna=0
      do i=1,nla
         do j=1,nalamax
            nna1=nna1+1
            if (j.le.nalayer(i)) then
               nna=nna+1
               narid(nna)=nna-napre5
               naext(nna)=nna1
               write(81,*) narid(nna),naext(nna)
            end if
         end do
      end do
      close(81)
c
c---------------------------------------------------
c
c      open(unit=12,file='potential.dat',status='unknown')
c      do i=1,nla
c         do j=1,nalayer(i)
c            read(12,*) pot(i,j)
cc            pot(i,j)=pot(i,j)*q
ccc           in Joule
c         end do
c      end do
c      close(12)
c

      es = skparameters(1)
      ep= skparameters(2)
      ew= skparameters(3)
      ed= skparameters(4)
      ss1= skparameters(5)
      ww1= skparameters(6)
      sw1= skparameters(7)
      sp1= skparameters(8)
      wp1= skparameters(9)
      sd1= skparameters(10)
      wd1= skparameters(11)
      pp1= skparameters(12)
      pp2= skparameters(13)
      pd1= skparameters(14)
      pd2= skparameters(15)
      dd1= skparameters(16)
      dd2= skparameters(17)
      dd3= skparameters(18)

c      open(unit=13,file='skparameters.dat',status='unknown')
c      read(13,*) es
c      read(13,*) ep
c      read(13,*) ew
c      read(13,*) ed
c      read(13,*) ss1
c      read(13,*) ww1
c      read(13,*) sw1
c      read(13,*) sp1
c      read(13,*) wp1
c      read(13,*) sd1
c      read(13,*) wd1
c      read(13,*) pp1
c      read(13,*) pp2
c      read(13,*) pd1
c      read(13,*) pd2
c      read(13,*) dd1
c      read(13,*) dd2
c      read(13,*) dd3
c     w is s*, 1 is sigma, 2 is pi, 3 is delta
c      close(13)
c
c COMMENT TO THE OLD WAY OF PASSING DELTAE
c      open(unit=15,file='deltae.dat',status='unknown')
c      read(15,*) deltae
c      close(15)
c
c      es=es*q
c      ep=ep*q
c      ew=ew*q
c      ed=ed*q
c      ss1=ss1*q
c      ww1=ww1*q
c      sw1=sw1*q
c      sp1=sp1*q
c      wp1=wp1*q
c      sd1=sd1*q
c      wd1=wd1*q
c      pp1=pp1*q
c      pp2=pp2*q
c      pd1=pd1*q
c      pd2=pd2*q
c      dd1=dd1*q
c      dd2=dd2*q
c      dd3=dd3*q
c      deltae=deltae*q
cc     in Joule
c
      call matrix(*10,nla,nalayer,ty,up1,tup1,up2,tup2,
     #do1,tdo1,do2,tdo2,es,ep,ew,ed,ss1,ww1,sw1,sp1,
     #wp1,sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,deltae,
     #pot,prevorb,norb,diag,
c     #subdiag,
     #superdiag,nlay,natol)
cc
cc
c      open(unit=50,file='hamrid.dat',status='unknown')
cc
c      do i=5,nla-4
c         do j=1,nalayer(i)
c            pr=prevorb(i,j)
cc
c            do i1=1,10
c               do j1=1,10
c                  write(50,90) narid(na(i,j)),'(',i1,')',
c     #                         narid(na(i,j)),'(',j1,')',
c     #                                diag(i,pr+i1,pr+j1)
c               end do
c            end do
cc
c            if (i.ne.(nla-4)) then
cc
c               if (up1(i,j).lt.up2(i,j)) then
cc
c                  if (up1(i,j).gt.0) then
c                     pr1=prevorb(i+1,up1(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(50,90) narid(na(i,j)),'(',i1,')',
c     #                         narid(na(i+1,up1(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c                  if (up2(i,j).gt.0) then
c                     pr1=prevorb(i+1,up2(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(50,90) narid(na(i,j)),'(',i1,')',
c     #                         narid(na(i+1,up2(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c               else
cc
c                  if (up2(i,j).gt.0) then
c                     pr1=prevorb(i+1,up2(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(50,90) narid(na(i,j)),'(',i1,')',
c     #                         narid(na(i+1,up2(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c                  if (up1(i,j).gt.0) then
c                     pr1=prevorb(i+1,up1(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(50,90) narid(na(i,j)),'(',i1,')',
c     #                         narid(na(i+1,up1(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c               end if
cc
c            end if
cc
c         end do
c      end do
cc
c      close(50)
cc
cc
      open(unit=51,file='hamrid1.dat',status='unknown')
c
      write(51,91) '['
c
      write(51,92) '[',10,', ',0
      do i1=1,10
         do j1=1,10
            write(51,93) ', ',0.0d0
         end do
      end do
      write(51,91) ']'
c
      do i=5,nla-4
         do j=1,nalayer(i)
            pr=prevorb(i,j)
c
            write(51,92) '[',narid(na(i,j)),', ',
     #                       narid(na(i,j))
            do i1=1,10
               do j1=1,10
                  write(51,93) ', ',diag(i,pr+i1,pr+j1)
               end do
            end do
            write(51,91) ']'
c
            if (i.ne.(nla-4)) then
c
               if (up1(i,j).lt.up2(i,j)) then
c
                  if (up1(i,j).gt.0) then
                     pr1=prevorb(i+1,up1(i,j))
                     write(51,92) '[',narid(na(i,j)),', ',
     #                                narid(na(i+1,up1(i,j)))
                     do i1=1,10
                        do j1=1,10
                           write(51,93) ', ',superdiag(i,pr+i1,pr1+j1)
                        end do
                     end do
                     write(51,91) ']'
                  end if
c
                  if (up2(i,j).gt.0) then
                     pr1=prevorb(i+1,up2(i,j))
                     write(51,92) '[',narid(na(i,j)),', ',
     #                                narid(na(i+1,up2(i,j)))
                     do i1=1,10
                        do j1=1,10
                           write(51,93) ', ',superdiag(i,pr+i1,pr1+j1)
                        end do
                     end do
                     write(51,91) ']'
                  end if
c
               else
c
                  if (up2(i,j).gt.0) then
                     pr1=prevorb(i+1,up2(i,j))
                     write(51,92) '[',narid(na(i,j)),', ',
     #                                narid(na(i+1,up2(i,j)))
                     do i1=1,10
                        do j1=1,10
                           write(51,93) ', ',superdiag(i,pr+i1,pr1+j1)
                        end do
                     end do
                     write(51,91) ']'
                  end if
c
                  if (up1(i,j).gt.0) then
                     pr1=prevorb(i+1,up1(i,j))
                     write(51,92) '[',narid(na(i,j)),', ',
     #                                narid(na(i+1,up1(i,j)))
                     do i1=1,10
                        do j1=1,10
                           write(51,93) ', ',superdiag(i,pr+i1,pr1+j1)
                        end do
                     end do
                     write(51,91) ']'
                  end if
c
               end if
c
            end if
c
         end do
      end do
c
      write(51,91) ']'
c
      close(51)
c
c
      open(unit=40,file='norb.dat',status='unknown')
      do i=1,nla
         write(40,*) norb(i)
c        total number of atomic orbitals to be considered in each layer
      end do
      close(40)
c
      open(unit=44,file='norb1.dat',status='unknown')
      do i=4,nla-3
         write(44,*) norb(i)
c        total number of atomic orbitals to be considered in each layer
      end do
      close(44)
c
c      open(unit=45,file='diag.dat',status='unknown')
c      do i=1,nla
c         do i1=1,norb(i)
c            do j1=1,norb(i)
c               write(45,*) diag(i,i1,j1)
c            end do
c         end do
c      end do
c      close(45)
c
      open(unit=41,file='diag1.dat',status='unknown')
      do i=4,nla-3
         do i1=1,norb(i)
            do j1=1,norb(i)
               write(41,*) diag(i,i1,j1)
            end do
         end do
      end do
      close(41)
c
c      open(unit=46,file='superdiag.dat',status='unknown')
c      do i=1,nla-1
c         do i1=1,norb(i)
c            do j1=1,norb(i+1)
c               write(46,*) superdiag(i,i1,j1)
c            end do
c         end do
c      end do
c      close(46)
c
      open(unit=42,file='superdiag1.dat',status='unknown')
      do i=4,nla-4
         do i1=1,norb(i)
            do j1=1,norb(i+1)
               write(42,*) superdiag(i,i1,j1)
            end do
         end do
      end do
      close(42)
cc
cc      open(unit=47,file='subdiag.dat',status='unknown')
cc      do i=1,nla-1
cc         do i1=1,norb(i+1)
cc            do j1=1,norb(i)
cc               write(47,*) subdiag(i,i1,j1)
cc            end do
cc         end do
cc      end do
cc      close(47)
cc
c      open(unit=43,file='subdiag1.dat',status='unknown')
c      do i=4,nla-4
c         do i1=1,norb(i+1)
c            do j1=1,norb(i)
c               write(43,*) subdiag(i,i1,j1)
c            end do
c         end do
c      end do
c      close(43)
cc
c      ordh1=0
c      do i=4,nla-3
c         ordh1=ordh1+norb(i)
c      end do
c      open(unit=94,file='ordh1.dat',status='unknown')
c      write(94,*) ordh1
c      close(94)
cc
c      do i=1,ordh1
c         do j=1,ordh1
c            hami1(i,j)=0.0d0
c         end do
c      end do
cc
c      prorbl(4)=0
c      do i=4,nla-4
c         prorbl(i+1)=prorbl(i)+norb(i)
cc        number of atomic orbitals to be considered before the i-th layer
c      end do
cc
c      open(unit=48,file='hamiltonian.dat',status='unknown')
c      do i=4,nla-3
c         do i1=1,norb(i)
c            do j=4,nla-3
c               do j1=1,norb(j)
c                  if (i.eq.j+1) then
c                     write(48,*) prorbl(i)+i1,prorbl(j)+j1,
c     #                           subdiag(j,i1,j1)
c                     hami1(prorbl(i)+i1,prorbl(j)+j1)=subdiag(j,i1,j1)
c                  else if (i.eq.j) then
c                     write(48,*) prorbl(i)+i1,prorbl(j)+j1,
c     #                           diag(i,i1,j1)
c                     hami1(prorbl(i)+i1,prorbl(j)+j1)=diag(i,i1,j1)
c                  else if (i.eq.j-1) then
c                     write(48,*) prorbl(i)+i1,prorbl(j)+j1,
c     #                           superdiag(i,i1,j1)
c                     hami1(prorbl(i)+i1,prorbl(j)+j1)=superdiag(i,i1,j1)
c                  else
c                     write(48,*) prorbl(i)+i1,prorbl(j)+j1,
c     #                           0.0d0
c                     hami1(prorbl(i)+i1,prorbl(j)+j1)=0.0d0
c                  end if
c               end do
c            end do
c         end do
c      end do
c      close(48)
cc
cc     check if H is symmetrical
cc
c      open(unit=88,file='test1.dat',status='unknown')
c      do i=1,ordh1
c         do j=1,ordh1
c            if (hami1(i,j).ne.hami1(j,i)) then
c               write(88,*) i,j
c               write(88,*) 'i,j',hami1(i,j)
c               write(88,*) 'j,i',hami1(j,i)
c               write(88,*) 'diff',hami1(i,j)-hami1(j,i)
c               write(88,*) ''
c            end if
c         end do
c      end do
c      close(88)
cc
c      nat1=0
c      do i=4,nla-3
c         nat1=nat1+nalayer(i)
c      end do
cc
c      open(unit=48,file='hamiltonian.dat',status='unknown')
c      open(unit=49,file='hamiltonianbis.dat',status='unknown')
c      do i=1,nat1*10
c         do j=1,nat1*10
c            read(48,*) num1,num2,val
c            num1a=1+(num1-1)/10-nalayer(4)
c            num1o=num1-(num1a-1)*10
c            if (num1o.eq.1) then
c               str1='s             '
c            else if (num1o.eq.2) then
c               str1='px            '
c            else if (num1o.eq.3) then
c               str1='py            '
c            else if (num1o.eq.4) then
c               str1='pz            '
c            else if (num1o.eq.5) then
c               str1='dxy           '
c            else if (num1o.eq.6) then
c               str1='dyz           '
c            else if (num1o.eq.7) then
c               str1='dzx           '
c            else if (num1o.eq.8) then
c               str1='d(x**2-y**2)  '
c            else if (num1o.eq.9) then
c               str1='d(3z**2-r**2) '
c            else if (num1o.eq.10) then
c               str1='s*            '
c            end if
c            num2a=1+(num2-1)/10-nalayer(4)
c            num2o=num2-(num2a-1)*10
c            if (num2o.eq.1) then
c               str2='s             '
c            else if (num2o.eq.2) then
c               str2='px            '
c            else if (num2o.eq.3) then
c               str2='py            '
c            else if (num2o.eq.4) then
c               str2='pz            '
c            else if (num2o.eq.5) then
c               str2='dxy           '
c            else if (num2o.eq.6) then
c               str2='dyz           '
c            else if (num2o.eq.7) then
c               str2='dzx           '
c            else if (num2o.eq.8) then
c               str2='d(x**2-y**2)  '
c            else if (num2o.eq.9) then
c               str2='d(3z**2-r**2) '
c            else if (num2o.eq.10) then
c               str2='s*            '
c            end if
c            write(49,*) num1a,str1,num2a,str2,val
c         end do
c      end do
c      close(48)
c      close(49)
cc
cc/////////////////////////////////////////////////
cc
c      ordh=0
c      do i=5,8
c         ordh=ordh+norb(i)
c      end do
c      open(unit=83,file='ordh.dat',status='unknown')
c      write(83,*) ordh
c      close(83)
cc
c      open(unit=87,file='snumk.dat',status='unknown')
c      read(87,*) snumk
cc     half-number of k's to consider in the nanowire Brillouin zone
c      close(87)
cc
c      do i=1,4
c         norbh(i)=norb(i+4)
c      end do
c      preorbla(1)=0
c      do i=1,3
c         preorbla(i+1)=preorbla(i)+norbh(i)
c      end do
cc
c      a=5.431d0
cc     in Angstrom
c      pi=acos(-1.0d0)
c      dk=pi/(a*snumk)
cc     in Angstrom**(-1)
c      ui=(0.0d0,1.0d0)
cc     imaginary unit
cc
c      do ll=1,snumk+1
c         k=(ll-1)*dk
cc
c         do i=1,ordh
c            do j=1,ordh
c               hami(i,j)=0.0d0
c            end do
c         end do
cc
c         do i=1,4
c            pre=preorbla(i)
c            do i1=1,norbh(i)
c               do j1=1,norbh(i)
c                  hami(pre+i1,pre+j1)=diag(i+4,i1,j1)
c               end do
c            end do
c         end do
c         do i=1,3
c            pre=preorbla(i)
c            pre1=preorbla(i+1)
c            do i1=1,norbh(i)
c               do j1=1,norbh(i+1)
c                  hami(pre+i1,pre1+j1)=superdiag(i+4,i1,j1)
c                  hami(pre1+j1,pre+i1)=subdiag(i+4,j1,i1)
c               end do
c            end do
c         end do
c         pre=preorbla(4)
c         pre1=preorbla(1)
c         do i1=1,norbh(4)
c            do j1=1,norbh(1)
c               hami(pre+i1,pre1+j1)=superdiag(8,i1,j1)*exp(ui*k*a)
c               hami(pre1+j1,pre+i1)=subdiag(4,j1,i1)*exp(-ui*k*a)
c            end do
c         end do
cc
cc        check if H is Hermitian
cc
c         open(unit=84,file='test2.dat',status='unknown',access='append')
c         do i=1,ordh
c            do j=1,ordh
c               if (hami(i,j).ne.dconjg(hami(j,i))) then
c                  write(84,*) ll,i,j
c                  write(84,*) 'i,j',dreal(hami(i,j)),dimag(hami(i,j))
c                  write(84,*) 'j,i',dreal(hami(j,i)),dimag(hami(j,i))
c                  write(84,*) 'diff',dreal(hami(i,j)-dconjg(hami(j,i))),
c     #                               dimag(hami(i,j)-dconjg(hami(j,i)))
c                  write(84,*) ''
c               end if
c            end do
c         end do
c         close(84)
cc
c         call zheev('N','U',ordh,hami,4*natol*10,en,work,2*ordh,
c     #               rwork,info)
cc        pay attention to put the correct leading dimension
cc        (i.e. the dimension of the variable declaration)!
cc
c         do i=1,ordh
c            if (i.lt.10) then
c               str1a=char(ichar('0')+i)
c               nc=1
c            else
c               na1=i
c               na2=na1/10
c               rem=mod(na1,10)
c               str1a=char(ichar('0')+rem)
c               nc=1
c               na1=na2
c 24            if (na2.lt.10) goto 34
c               na2=na1/10
c               rem=mod(na1,10)
c               str1a=char(ichar('0')+rem)//str1a(1:nc)
c               nc=nc+1
c               na1=na2
c               goto 24
c 34            str1a=char(ichar('0')+na1)//str1a(1:nc)
c               nc=nc+1
c            end if
c            if (30.lt.(nc+8)) then
c                write(*,*) 'change 30: 30<(nc+8) !!'
c                goto 10
c            end if
c            str2a='band'//str1a(1:nc)//'.dat'
c            open(unit=84,file=str2a,status='unknown',access='append')
cc            write(84,*) k/(pi/a),en(i)/q
c            write(84,*) k/(pi/a),en(i)
cc           k in units of pi/a; energy in eV
c            close(84)
c         end do
c         if (ll.eq.1) then
c            open(unit=85,file='enk0.dat',status='unknown')
c            do i=1,ordh
c               write(85,*) en(i)
c            end do
c            close(85)
c         end if
cc
cc
c      end do
cc
cc
c      open(unit=86,file='bands.dat',status='unknown')
c      do i=1,ordh
c         if (i.lt.10) then
c            str1a=char(ichar('0')+i)
c            nc=1
c         else
c            na1=i
c            na2=na1/10
c            rem=mod(na1,10)
c            str1a=char(ichar('0')+rem)
c            nc=1
c            na1=na2
c 44         if (na2.lt.10) goto 54
c            na2=na1/10
c            rem=mod(na1,10)
c            str1a=char(ichar('0')+rem)//str1a(1:nc)
c            nc=nc+1
c            na1=na2
c            goto 44
c 54         str1a=char(ichar('0')+na1)//str1a(1:nc)
c            nc=nc+1
c         end if
c         if (30.lt.(nc+8)) then
c            write(*,*) 'change 30: 30<(nc+8) !!'
c            goto 10
c         end if
c         str2a='band'//str1a(1:nc)//'.dat'
c         open(unit=85,file=str2a,status='unknown')
c         do ll=1,snumk+1
c            read(85,*) val1,val2
c            write(86,*) val1,val2
c         end do
c         close(85)
c         write(86,*) ' '
c      end do
c      close(86)
cc
cc/////////////////////////////////////////////////
cc
c      open(unit=70,file='exthamrid.dat',status='unknown')
cc
c      do i=5,nla-4
c         do j=1,nalayer(i)
c            pr=prevorb(i,j)
cc
c            do i1=1,10
c               do j1=1,10
c                  write(70,90) naext(na(i,j)),'(',i1,')',
c     #                         naext(na(i,j)),'(',j1,')',
c     #                                diag(i,pr+i1,pr+j1)
c               end do
c            end do
cc
c            if (i.ne.(nla-4)) then
cc
c               if (up1(i,j).lt.up2(i,j)) then
cc
c                  if (up1(i,j).gt.0) then
c                     pr1=prevorb(i+1,up1(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(70,90) naext(na(i,j)),'(',i1,')',
c     #                         naext(na(i+1,up1(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c                  if (up2(i,j).gt.0) then
c                     pr1=prevorb(i+1,up2(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(70,90) naext(na(i,j)),'(',i1,')',
c     #                         naext(na(i+1,up2(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c               else
cc
c                  if (up2(i,j).gt.0) then
c                     pr1=prevorb(i+1,up2(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(70,90) naext(na(i,j)),'(',i1,')',
c     #                         naext(na(i+1,up2(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c                  if (up1(i,j).gt.0) then
c                     pr1=prevorb(i+1,up1(i,j))
c                     do i1=1,10
c                        do j1=1,10
c                           write(70,90) naext(na(i,j)),'(',i1,')',
c     #                         naext(na(i+1,up1(i,j))),'(',j1,')',
c     #                                   superdiag(i,pr+i1,pr1+j1)
c                        end do
c                     end do
c                  end if
cc
c               end if
cc
c            end if
cc
c         end do
c      end do
cc
c      close(70)
cc
cc
      open(unit=71,file='exthamrid1.dat',status='unknown')
c
c     write(71,91) '['
c

      k_in = 0
      write(71,95) 10,', ',0
      k_in = k_in + 1
      H_aux(k_in) = 10
      k_in = k_in + 1
      H_aux(k_in) = 0

      do i1=1,10
         do j1=1,10
            write(71,93) ', ',0.0d0
            k_in = k_in + 1
            H_aux(k_in) = 0
         end do
      end do
      write(71,91) ']'
c
      do i=5,nla-4
         do j=1,nalayer(i)
            pr=prevorb(i,j)
c
            write(71,92) '[',naext(na(i,j)),', ',
     #                       naext(na(i,j))

            k_in = k_in + 1
            H_aux(k_in) = naext(na(i,j))
c            write(*,*) naext(na(i,j))
c            write(*,*) H_aux(k_in)
            k_in = k_in + 1
            H_aux(k_in) = naext(na(i,j))

            do i1=1,10
               do j1=1,10
                  write(71,93) ', ',diag(i,pr+i1,pr+j1)

                  k_in = k_in + 1
                  H_aux(k_in) = diag(i,pr+i1,pr+j1)

               end do
            end do
            if (i.eq.nla-4.and.j.eq.nalayer(nla-4)) then
               goto 100
            end if
            write(71,91) ']'
 100        continue

c
            if (i.ne.(nla-4)) then
c
               if (up1(i,j).lt.up2(i,j)) then
c
                  if (up1(i,j).gt.0) then
                     pr1=prevorb(i+1,up1(i,j))
                     write(71,92) '[',naext(na(i,j)),', ',
     #                                naext(na(i+1,up1(i,j)))

                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i,j))
                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i+1,up1(i,j)))

                     do i1=1,10
                        do j1=1,10
                           write(71,93) ', ',superdiag(i,pr+i1,pr1+j1)

                           k_in = k_in + 1
                           H_aux(k_in) = superdiag(i,pr+i1,pr1+j1)

                        end do
                     end do
                     write(71,91) ']'
                  end if
c
                  if (up2(i,j).gt.0) then
                     pr1=prevorb(i+1,up2(i,j))
                     write(71,92) '[',naext(na(i,j)),', ',
     #                                naext(na(i+1,up2(i,j)))

                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i,j))
                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i+1,up2(i,j)))

                     do i1=1,10
                        do j1=1,10
                           write(71,93) ', ',superdiag(i,pr+i1,pr1+j1)

                           k_in = k_in + 1
                           H_aux(k_in) = superdiag(i,pr+i1,pr1+j1)

                        end do
                     end do
                     write(71,91) ']'
                  end if
c
               else
c
                  if (up2(i,j).gt.0) then
                     pr1=prevorb(i+1,up2(i,j))
                     write(71,92) '[',naext(na(i,j)),', ',
     #                                naext(na(i+1,up2(i,j)))

                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i,j))
                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i+1,up2(i,j)))

                     do i1=1,10
                        do j1=1,10
                           write(71,93) ', ',superdiag(i,pr+i1,pr1+j1)

                           k_in = k_in + 1
                           H_aux(k_in) = superdiag(i,pr+i1,pr1+j1)

                        end do
                     end do
                     write(71,91) ']'
                  end if
c
                  if (up1(i,j).gt.0) then
                     pr1=prevorb(i+1,up1(i,j))
                     write(71,92) '[',naext(na(i,j)),', ',
     #                                naext(na(i+1,up1(i,j)))

                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i,j))
                     k_in = k_in + 1
                     H_aux(k_in) = naext(na(i+1,up1(i,j)))

                     do i1=1,10
                        do j1=1,10
                           write(71,93) ', ',superdiag(i,pr+i1,pr1+j1)

                           k_in = k_in + 1
                           H_aux(k_in) = superdiag(i,pr+i1,pr1+j1)

                        end do
                     end do
                     write(71,91) ']'
                  end if
c
               end if
c
            end if
c
         end do
      end do
c
c      write(71,91) ']'
c
      close(71)
c
c
c      open(unit=65,file='extdiag.dat',status='unknown')
c      do i=1,nla
c         do i1=1,nalamax*10
c            do j1=1,nalamax*10
c               if ((i1.le.norb(i)).and.(j1.le.norb(i))) then
c                  write(65,*) diag(i,i1,j1)
c               else
c                  write(65,*) 0.0d0
c               end if
c            end do
c         end do
c      end do
c      close(65)
c
      open(unit=61,file='extdiag1.dat',status='unknown')
      do i=4,nla-3
         do i1=1,nalamax*10
            do j1=1,nalamax*10
               if ((i1.le.norb(i)).and.(j1.le.norb(i))) then
                  write(61,*) diag(i,i1,j1)
               else
                  write(61,*) 0.0d0
               end if
            end do
         end do
      end do
      close(61)
c
c      open(unit=66,file='extsuperdiag.dat',status='unknown')
c      do i=1,nla-1
c         do i1=1,nalamax*10
c            do j1=1,nalamax*10
c               if ((i1.le.norb(i)).and.(j1.le.norb(i+1))) then
c                  write(66,*) superdiag(i,i1,j1)
c               else
c                  write(66,*) 0.0d0
c               end if
c            end do
c         end do
c      end do
c      close(66)
c
      open(unit=62,file='extsuperdiag1.dat',status='unknown')
      do i=4,nla-4
         do i1=1,nalamax*10
            do j1=1,nalamax*10
               if ((i1.le.norb(i)).and.(j1.le.norb(i+1))) then
                  write(62,*) superdiag(i,i1,j1)
               else
                  write(62,*) 0.0d0
               end if
            end do
         end do
      end do
      close(62)
cc
cc      open(unit=67,file='extsubdiag.dat',status='unknown')
cc      do i=1,nla-1
cc         do i1=1,nalamax*10
cc            do j1=1,nalamax*10
cc               if ((i1.le.norb(i+1)).and.(j1.le.norb(i))) then
cc                  write(67,*) subdiag(i,i1,j1)
cc               else
cc                  write(67,*) 0.0d0
cc               end if
cc            end do
cc         end do
cc      end do
cc      close(67)
cc
c      open(unit=63,file='extsubdiag1.dat',status='unknown')
c      do i=4,nla-4
c         do i1=1,nalamax*10
c            do j1=1,nalamax*10
c               if ((i1.le.norb(i+1)).and.(j1.le.norb(i))) then
c                  write(63,*) subdiag(i,i1,j1)
c               else
c                  write(63,*) 0.0d0
c               end if
c            end do
c         end do
c      end do
c      close(63)
cc
c      ordhe1=6*nalamax*10
c      open(unit=95,file='ordhe1.dat',status='unknown')
c      write(95,*) ordhe1
c      close(95)
cc
c      do i=1,ordhe1
c         do j=1,ordhe1
c            hamie1(i,j)=0.0d0
c         end do
c      end do
cc
c      do i=4,nla-3
c         prorbl1(i)=(i-4)*nalamax*10
c      end do
cc
c      open(unit=68,file='exthamiltonian.dat',status='unknown')
c      do i=4,nla-3
c         do i1=1,nalamax*10
c            do j=4,nla-3
c               do j1=1,nalamax*10
c                  if ((i1.le.norb(i)).and.(j1.le.norb(j))) then
c                     if (i.eq.j+1) then
c                        write(68,*) prorbl1(i)+i1,prorbl1(j)+j1,
c     #                              subdiag(j,i1,j1)
c                        hamie1(prorbl1(i)+i1,prorbl1(j)+j1)=
c     #                       subdiag(j,i1,j1)
c                     else if (i.eq.j) then
c                        write(68,*) prorbl1(i)+i1,prorbl1(j)+j1,
c     #                              diag(i,i1,j1)
c                        hamie1(prorbl1(i)+i1,prorbl1(j)+j1)=
c     #                       diag(i,i1,j1)
c                     else if (i.eq.j-1) then
c                        write(68,*) prorbl1(i)+i1,prorbl1(j)+j1,
c     #                              superdiag(i,i1,j1)
c                        hamie1(prorbl1(i)+i1,prorbl1(j)+j1)=
c     #                       superdiag(i,i1,j1)
c                     else
c                        write(68,*) prorbl1(i)+i1,prorbl1(j)+j1,
c     #                              0.0d0
c                        hamie1(prorbl1(i)+i1,prorbl1(j)+j1)=
c     #                       0.0d0
c                     end if
c                  else
c                     write(68,*) prorbl1(i)+i1,prorbl1(j)+j1,0.0d0
c                     hamie1(prorbl1(i)+i1,prorbl1(j)+j1)=0.0d0
c                  end if
c               end do
c            end do
c         end do
c      end do
c      close(68)
cc
cc
cc     check if H is symmetrical
cc
c      open(unit=89,file='test3.dat',status='unknown')
c      do i=1,ordhe1
c         do j=1,ordhe1
c            if (hamie1(i,j).ne.hamie1(j,i)) then
c               write(89,*) i,j
c               write(89,*) 'i,j',hamie1(i,j)
c               write(89,*) 'j,i',hamie1(j,i)
c               write(89,*) 'diff',hamie1(i,j)-hamie1(j,i)
c               write(89,*) ''
c            end if
c         end do
c      end do
c      close(89)
c
c      open(unit=68,file='exthamiltonian.dat',status='unknown')
c      open(unit=69,file='exthamiltonianbis.dat',status='unknown')
c      do i=1,(nla-6)*nalamax*10
c         do j=1,(nla-6)*nalamax*10
c            read(68,*) num1,num2,val
c            num1a=1+(num1-1)/10-nalamax
c            num1o=num1-(num1a-1)*10
c            if (num1o.eq.1) then
c               str1='s             '
c            else if (num1o.eq.2) then
c               str1='px            '
c            else if (num1o.eq.3) then
c               str1='py            '
c            else if (num1o.eq.4) then
c               str1='pz            '
c            else if (num1o.eq.5) then
c               str1='dxy           '
c            else if (num1o.eq.6) then
c               str1='dyz           '
c            else if (num1o.eq.7) then
c               str1='dzx           '
c            else if (num1o.eq.8) then
c               str1='d(x**2-y**2)  '
c            else if (num1o.eq.9) then
c               str1='d(3z**2-r**2) '
c            else if (num1o.eq.10) then
c               str1='s*            '
c            end if
c            num2a=1+(num2-1)/10-nalamax
c            num2o=num2-(num2a-1)*10
c            if (num2o.eq.1) then
c               str2='s             '
c            else if (num2o.eq.2) then
c               str2='px            '
c            else if (num2o.eq.3) then
c               str2='py            '
c            else if (num2o.eq.4) then
c               str2='pz            '
c            else if (num2o.eq.5) then
c               str2='dxy           '
c            else if (num2o.eq.6) then
c               str2='dyz           '
c            else if (num2o.eq.7) then
c               str2='dzx           '
c            else if (num2o.eq.8) then
c               str2='d(x**2-y**2)  '
c            else if (num2o.eq.9) then
c               str2='d(3z**2-r**2) '
c            else if (num2o.eq.10) then
c               str2='s*            '
c            end if
c            write(69,*) num1a,str1,num2a,str2,val
c         end do
c      end do
c      close(68)
c      close(69)
cc
cc/////////////////////////////////////////////////
cc
c      ordhe=4*nalamax*10
c      open(unit=96,file='ordhe.dat',status='unknown')
c      write(96,*) ordhe
c      close(96)
cc
c      preorblae(1)=0
c      do i=1,3
c         preorblae(i+1)=preorblae(i)+nalamax*10
c      end do
cc
c      do ll=1,snumk+1
c         k=(ll-1)*dk
cc
c         do i=1,ordhe
c            do j=1,ordhe
c               hamie(i,j)=0.0d0
c            end do
c         end do
cc
c         do i=1,4
c            pre=preorblae(i)
c            do i1=1,nalamax*10
c               do j1=1,nalamax*10
c                  if ((i1.le.norb(i)).and.(j1.le.norb(i))) then
c                     hamie(pre+i1,pre+j1)=diag(i+4,i1,j1)
c                  else
c                     hamie(pre+i1,pre+j1)=0.0d0
c                  end if
c               end do
c            end do
c         end do
c         do i=1,3
c            pre=preorblae(i)
c            pre1=preorblae(i+1)
c            do i1=1,nalamax*10
c               do j1=1,nalamax*10
c                  if ((i1.le.norb(i)).and.(j1.le.norb(i+1))) then
c                     hamie(pre+i1,pre1+j1)=superdiag(i+4,i1,j1)
c                     hamie(pre1+j1,pre+i1)=subdiag(i+4,j1,i1)
c                  else
c                     hamie(pre+i1,pre1+j1)=0.0d0
c                     hamie(pre1+j1,pre+i1)=0.0d0
c                  end if
c               end do
c            end do
c         end do
c         pre=preorblae(4)
c         pre1=preorblae(1)
c         do i1=1,nalamax*10
c            do j1=1,nalamax*10
c               if ((i1.le.norb(4)).and.(j1.le.norb(1))) then
c                  hamie(pre+i1,pre1+j1)=superdiag(8,i1,j1)*exp(ui*k*a)
c                  hamie(pre1+j1,pre+i1)=subdiag(4,j1,i1)*exp(-ui*k*a)
c               else
c                  hamie(pre+i1,pre1+j1)=0.0d0
c                  hamie(pre1+j1,pre+i1)=0.0d0
c               end if
c            end do
c         end do
cc
cc        check if H is Hermitian
cc
c         open(unit=104,file='test4.dat',status='unknown',
c     #                                                  access='append')
c         do i=1,ordhe
c            do j=1,ordhe
c               if (hamie(i,j).ne.dconjg(hamie(j,i))) then
c                  write(104,*) ll,i,j
c                  write(104,*) 'i,j',dreal(hamie(i,j)),dimag(hamie(i,j))
c                  write(104,*) 'j,i',dreal(hamie(j,i)),dimag(hamie(j,i))
c                  write(104,*) 'diff',
c     #                             dreal(hamie(i,j)-dconjg(hamie(j,i))),
c     #                             dimag(hamie(i,j)-dconjg(hamie(j,i)))
c                  write(104,*) ''
c               end if
c            end do
c         end do
c         close(104)
c
c         call zheev('N','U',ordhe,hamie,4*natol*10,en,work,2*ordhe,
c     #               rwork,info)
cc        pay attention to put the correct leading dimension
cc        (i.e. the dimension of the variable declaration)!
c
c         do i=1,ordhe
c            if (i.lt.10) then
c               str1ae=char(ichar('0')+i)
c               nc=1
c            else
c               na1=i
c               na2=na1/10
c               rem=mod(na1,10)
c               str1ae=char(ichar('0')+rem)
c               nc=1
c               na1=na2
c 64            if (na2.lt.10) goto 74
c               na2=na1/10
c               rem=mod(na1,10)
c               str1ae=char(ichar('0')+rem)//str1ae(1:nc)
c               nc=nc+1
c               na1=na2
c               goto 64
c 74            str1ae=char(ichar('0')+na1)//str1ae(1:nc)
c               nc=nc+1
c            end if
c            if (31.lt.(nc+9)) then
c                write(*,*) 'change 31: 31<(nc+9) !!'
c                goto 10
c            end if
c            str2ae='band'//str1ae(1:nc)//'e.dat'
c            open(unit=104,file=str2ae,status='unknown',access='append')
cc            write(104,*) k/(pi/a),en(i)/q
c            write(104,*) k/(pi/a),en(i)
cc           k in units of pi/a; energy in eV
c            close(104)
c         end do
c         if (ll.eq.1) then
c            open(unit=105,file='enk0e.dat',status='unknown')
c            do i=1,ordhe
c               write(105,*) en(i)
c            end do
c            close(105)
c         end if
cc
cc
c      end do
cc
cc
c      open(unit=106,file='bandse.dat',status='unknown')
c      do i=1,ordhe
c         if (i.lt.10) then
c            str1ae=char(ichar('0')+i)
c            nc=1
c         else
c            na1=i
c            na2=na1/10
c            rem=mod(na1,10)
c            str1ae=char(ichar('0')+rem)
c            nc=1
c            na1=na2
c 84         if (na2.lt.10) goto 94
c            na2=na1/10
c            rem=mod(na1,10)
c            str1ae=char(ichar('0')+rem)//str1ae(1:nc)
c            nc=nc+1
c            na1=na2
c            goto 84
c 94         str1ae=char(ichar('0')+na1)//str1ae(1:nc)
c            nc=nc+1
c         end if
c         if (31.lt.(nc+9)) then
c            write(*,*) 'change 31: 31<(nc+9) !!'
c            goto 10
c         end if
c         str2ae='band'//str1ae(1:nc)//'e.dat'
c         open(unit=105,file=str2ae,status='unknown')
c         do ll=1,snumk+1
c            read(105,*) val1,val2
c            write(106,*) val1,val2
c         end do
c         close(105)
c         write(106,*) ' '
c      end do
c      close(106)
c
c/////////////////////////////////////////////////
c
 90   format(i3,a1,i2,a1,3x,i3,a1,i2,a1,3x,f18.13)
 91   format(a1)
 92   format(a1,i5,a2,i5)
 93   format(a2,f18.13)
 95   format(i5,a2,i5)
c
c
      return

 10   end

c      return

c      end

      subroutine matrix(*,nla,nalayer,ty,up1,tup1,up2,tup2,
     #do1,tdo1,do2,tdo2,es,ep,ew,ed,ss1,ww1,sw1,sp1,
     #wp1,sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,deltae,
     #pot,prevorb,norb,diag,
c     #subdiag,
     #superdiag,nlay,natol)
c
      implicit none
      integer nlay,natol
c     maximum number of layers, maximum number of atoms per layer
      integer i,j,i1,j1,nla,nalayer(nlay),nl,natom,ty(nlay,natol),
     #up1(nlay,natol),up2(nlay,natol),tup1(nlay,natol),
     #tup2(nlay,natol),do1(nlay,natol),do2(nlay,natol),
     #tdo1(nlay,natol),tdo2(nlay,natol),
     #prevorb(nlay,natol),norb(nlay),pr,pr1,
     #upp1,upp2,doo1,doo2
      double precision es,ep,ew,ed,ss1,ww1,sw1,sp1,wp1,sd1,wd1,
     #pp1,pp2,pd1,pd2,dd1,dd2,dd3,l,m,n,invsq3,
     #h1(10,10),pot(nlay,natol),
     #diag(nlay,natol*10,natol*10),
c     #subdiag(nlay-1,natol*10,natol*10),
     #superdiag(nlay-1,natol*10,natol*10),
     #deltae,hpass(4,4)
c
c     in the Hamiltonian we put in the order the orbitals:
c     1:s, 2:px, 3:py, 4:pz, 5:dxy, 6:dyz, 7:dzx,
c     8:d(x**2-y**2), 9:d(3z**2-r**2), 10:w
c
      invsq3=1.0d0/sqrt(3.0d0)
c
      do i=1,nla
         do i1=1,norb(i)
            do j1=1,norb(i)
               diag(i,i1,j1)=0.0d0
            end do
         end do
      end do
      do i=1,nla-1
         do i1=1,norb(i)
            do j1=1,norb(i+1)
               superdiag(i,i1,j1)=0.0d0
            end do
         end do
      end do
c      do i=1,nla-1
c         do i1=1,norb(i+1)
c            do j1=1,norb(i)
c               subdiag(i,i1,j1)=0.0d0
c            end do
c         end do
c      end do
c
c
      do i=1,nla
         do j=1,nalayer(i)
            pr=prevorb(i,j)
c
c
            upp1=up1(i,j)
            upp2=up2(i,j)
            doo1=do1(i,j)
            doo2=do2(i,j)
            diag(i,pr+1,pr+1)=es+pot(i,j)
            diag(i,pr+2,pr+2)=ep+pot(i,j)
            diag(i,pr+3,pr+3)=ep+pot(i,j)
            diag(i,pr+4,pr+4)=ep+pot(i,j)
            if ((upp1.lt.0).or.(upp2.lt.0).or.(doo1.lt.0)
     #         .or.(doo2.lt.0)) then
               call passivation(upp1,upp2,doo1,doo2,deltae,hpass)
               do i1=1,4
                  do j1=1,4
                     diag(i,pr+i1,pr+j1)=
     #                  diag(i,pr+i1,pr+j1)+hpass(i1,j1)
                  end do
               end do
            end if
            diag(i,pr+5,pr+5)=ed+pot(i,j)
            diag(i,pr+6,pr+6)=ed+pot(i,j)
            diag(i,pr+7,pr+7)=ed+pot(i,j)
            diag(i,pr+8,pr+8)=ed+pot(i,j)
            diag(i,pr+9,pr+9)=ed+pot(i,j)
            diag(i,pr+10,pr+10)=ew+pot(i,j)
c
c
            if (up1(i,j).gt.0) then
               pr1=prevorb(i+1,up1(i,j))
               if (ty(i,j).eq.1) then
c                 nn-type=1 with respect to an anion
                  l=invsq3
                  m=invsq3
                  n=invsq3
               else
c                 nn-type=1 with respect to a cation
                  l=-invsq3
                  m=invsq3
                  n=invsq3
               end if
               call elementsitosi(l,m,n,ss1,ww1,sw1,sp1,wp1,
     #              sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,h1)
               do i1=1,10
                  do j1=1,10
                     superdiag(i,pr+i1,pr1+j1)=h1(i1,j1)
                  end do
               end do
            end if
c
c
            if (up2(i,j).gt.0) then
               pr1=prevorb(i+1,up2(i,j))
               if (ty(i,j).eq.1) then
c                 nn-type=2 with respect to an anion
                  l=-invsq3
                  m=-invsq3
                  n=invsq3
               else
c                 nn-type=2 with respect to a cation
                  l=invsq3
                  m=-invsq3
                  n=invsq3
               end if
               call elementsitosi(l,m,n,ss1,ww1,sw1,sp1,wp1,
     #              sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,h1)
               do i1=1,10
                  do j1=1,10
                     superdiag(i,pr+i1,pr1+j1)=h1(i1,j1)
                  end do
               end do
            end if
cc
cc
c            if (do1(i,j).gt.0) then
c               pr1=prevorb(i-1,do1(i,j))
c               if (ty(i,j).eq.1) then
cc                 nn-type=3 with respect to an anion
c                  l=invsq3
c                  m=-invsq3
c                  n=-invsq3
c               else
cc                 nn-type=3 with respect to a cation
c                  l=-invsq3
c                  m=-invsq3
c                  n=-invsq3
c               end if
c               call elementsitosi(l,m,n,ss1,ww1,sw1,sp1,wp1,
c     #              sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,h1)
c               do i1=1,10
c                  do j1=1,10
c                     subdiag(i-1,pr+i1,pr1+j1)=h1(i1,j1)
c                  end do
c               end do
c            end if
cc
cc
c            if (do2(i,j).gt.0) then
c               pr1=prevorb(i-1,do2(i,j))
c               if (ty(i,j).eq.1) then
cc                 nn-type=4 with respect to an anion
c                  l=-invsq3
c                  m=invsq3
c                  n=-invsq3
c               else
cc                 nn-type=4 with respect to a cation
c                  l=invsq3
c                  m=invsq3
c                  n=-invsq3
c               end if
c               call elementsitosi(l,m,n,ss1,ww1,sw1,sp1,wp1,
c     #              sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,h1)
c               do i1=1,10
c                  do j1=1,10
c                     subdiag(i-1,pr+i1,pr1+j1)=h1(i1,j1)
c                  end do
c               end do
c            end if
cc
cc
         end do
      end do
cc
cc     check if H is symmetric
cc
c      open(unit=14,file='test.dat',status='unknown')
c      do i=1,nla
c         do i1=1,norb(i)
c            do j1=1,norb(i)
c               if (diag(i,i1,j1).ne.diag(i,j1,i1)) then
c                  write(14,*) 'dr',i,i1,j1,
c     #                                diag(i,i1,j1)-diag(i,j1,i1)
c               end if
c            end do
c         end do
c      end do
c      do i=1,nla-1
c         do i1=1,norb(i)
c            do j1=1,norb(i+1)
c               if (superdiag(i,i1,j1).ne.subdiag(i,j1,i1)) then
c                  write(14,*) 's',i,i1,j1,
c     #                            superdiag(i,i1,j1)-subdiag(i,j1,i1)
c               end if
c            end do
c         end do
c      end do
c      close(14)
cc
cc
      end

      subroutine passivation(upp1,upp2,doo1,doo2,deltae,hpass)
c
      implicit none
      integer i,j,upp1,upp2,doo1,doo2,ancat,ind,l1,l2,l3,l4
      double precision deltae,hpass(4,4),const
c
      l1=0
      l2=0
      l3=0
      l4=0
c
      if (upp1.eq.-2) then
c        dangling bond in the direction [1 1 1] with respect to an anion
         ancat=1
         l1=1
      end if
      if (upp2.eq.-2) then
c        dangling bond in the direction [-1 -1 1] with respect to an anion
         ancat=1
         l2=1
      end if
      if (doo1.eq.-2) then
c        dangling bond in the direction [1 -1 -1] with respect to an anion
         ancat=1
         l3=1
      end if
      if (doo2.eq.-2) then
c        dangling bond in the direction [-1 1 -1] with respect to an anion
         ancat=1
         l4=1
      end if
c
      if (upp1.eq.-1) then
c        dangling bond in the direction [-1 1 1] with respect to a cation
         ancat=2
         l1=1
      end if
      if (upp2.eq.-1) then
c        dangling bond in the direction [1 -1 1] with respect to a cation
         ancat=2
         l2=1
      end if
      if (doo1.eq.-1) then
c        dangling bond in the direction [-1 -1 -1] with respect to a cation
         ancat=2
         l3=1
      end if
      if (doo2.eq.-1) then
c        dangling bond in the direction [1 1 -1] with respect to a cation
         ancat=2
         l4=1
      end if
c
      if (ancat.eq.1) then
c
         hpass(1,1)=l1+l2+l3+l4
         hpass(1,2)=l1-l2+l3-l4
         hpass(1,3)=l1-l2-l3+l4
         hpass(1,4)=l1+l2-l3-l4
         hpass(2,1)=l1-l2+l3-l4
         hpass(2,2)=l1+l2+l3+l4
         hpass(2,3)=l1+l2-l3-l4
         hpass(2,4)=l1-l2-l3+l4
         hpass(3,1)=l1-l2-l3+l4
         hpass(3,2)=l1+l2-l3-l4
         hpass(3,3)=l1+l2+l3+l4
         hpass(3,4)=l1-l2+l3-l4
         hpass(4,1)=l1+l2-l3-l4
         hpass(4,2)=l1-l2-l3+l4
         hpass(4,3)=l1-l2+l3-l4
         hpass(4,4)=l1+l2+l3+l4
c
      else
c
         hpass(1,1)=l1+l2+l3+l4
         hpass(1,2)=-l1+l2-l3+l4
         hpass(1,3)=l1-l2-l3+l4
         hpass(1,4)=l1+l2-l3-l4
         hpass(2,1)=-l1+l2-l3+l4
         hpass(2,2)=l1+l2+l3+l4
         hpass(2,3)=-l1-l2+l3+l4
         hpass(2,4)=-l1+l2+l3-l4
         hpass(3,1)=l1-l2-l3+l4
         hpass(3,2)=-l1-l2+l3+l4
         hpass(3,3)=l1+l2+l3+l4
         hpass(3,4)=l1-l2+l3-l4
         hpass(4,1)=l1+l2-l3-l4
         hpass(4,2)=-l1+l2+l3-l4
         hpass(4,3)=l1-l2+l3-l4
         hpass(4,4)=l1+l2+l3+l4
c
      end if
c
      const=deltae/4.0d0
c
      do i=1,4
         do j=1,4
            hpass(i,j)=hpass(i,j)*const
         end do
      end do
c
      end

c
c     1 is s,
c     2 is px,
c     3 is py,
c     4 is pz,
c     5 is dxy,
c     6 is dyz,
c     7 is dzx,
c     8 is d(x**2-y**2),
c     9 is d(3z**2-r**2),
c     10 is s* (i.e. w)
c

      subroutine elementsitosi(l,m,n,ss1,ww1,sw1,sp1,wp1,
     #sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,h1)
c     Hamiltonian elements from a Si atom to a Si atom
      implicit none
      double precision l,m,n,ss1,ww1,sw1,sp1,wp1,
     #sd1,wd1,pp1,pp2,pd1,pd2,dd1,dd2,dd3,h1(10,10),sq3,ha,qu
c
      sq3=sqrt(3.0d0)
      ha=1/2.0d0
      qu=1/4.0d0
c
      h1(1,1)=ss1
      h1(1,2)=l*sp1
      h1(1,3)=m*sp1
      h1(1,4)=n*sp1
      h1(1,5)=sq3*l*m*sd1
      h1(1,6)=sq3*m*n*sd1
      h1(1,7)=sq3*n*l*sd1
      h1(1,8)=ha*sq3*(l*l-m*m)*sd1
      h1(1,9)=(n*n-ha*(l*l+m*m))*sd1
      h1(1,10)=sw1
c
      h1(2,1)=-l*sp1
      h1(2,2)=l*l*pp1+(1-l*l)*pp2
      h1(2,3)=l*m*(pp1-pp2)
      h1(2,4)=n*l*(pp1-pp2)
      h1(2,5)=sq3*l*l*m*pd1+m*(1-2*l*l)*pd2
      h1(2,6)=l*m*n*(sq3*pd1-2*pd2)
      h1(2,7)=sq3*n*l*l*pd1+n*(1-2*l*l)*pd2
      h1(2,8)=ha*sq3*l*(l*l-m*m)*pd1+l*(1-l*l+m*m)*pd2
      h1(2,9)=l*(n*n-ha*(l*l+m*m))*pd1-sq3*l*n*n*pd2
      h1(2,10)=-l*wp1
c
      h1(3,1)=-m*sp1
      h1(3,2)=m*l*(pp1-pp2)
      h1(3,3)=m*m*pp1+(1-m*m)*pp2
      h1(3,4)=m*n*(pp1-pp2)
      h1(3,5)=sq3*l*m*m*pd1+l*(1-2*m*m)*pd2
      h1(3,6)=sq3*n*m*m*pd1+n*(1-2*m*m)*pd2
      h1(3,7)=l*m*n*(sq3*pd1-2*pd2)
      h1(3,8)=ha*sq3*m*(l*l-m*m)*pd1-m*(1+l*l-m*m)*pd2
      h1(3,9)=m*(n*n-ha*(l*l+m*m))*pd1-sq3*m*n*n*pd2
      h1(3,10)=-m*wp1
c
      h1(4,1)=-n*sp1
      h1(4,2)=n*l*(pp1-pp2)
      h1(4,3)=n*m*(pp1-pp2)
      h1(4,4)=n*n*pp1+(1-n*n)*pp2
      h1(4,5)=l*m*n*(sq3*pd1-2*pd2)
      h1(4,6)=sq3*m*n*n*pd1+m*(1-2*n*n)*pd2
      h1(4,7)=sq3*l*n*n*pd1+l*(1-2*n*n)*pd2
      h1(4,8)=ha*sq3*n*(l*l-m*m)*pd1-n*(l*l-m*m)*pd2
      h1(4,9)=n*(n*n-ha*(l*l+m*m))*pd1+sq3*n*(l*l+m*m)*pd2
      h1(4,10)=-n*wp1
c
      h1(5,1)=sq3*l*m*sd1
      h1(5,2)=-sq3*l*l*m*pd1-m*(1-2*l*l)*pd2
      h1(5,3)=-sq3*l*m*m*pd1-l*(1-2*m*m)*pd2
      h1(5,4)=-l*m*n*(sq3*pd1-2*pd2)
      h1(5,5)=3*l*l*m*m*dd1+(l*l+m*m-4*l*l*m*m)*dd2+(n*n+l*l*m*m)*dd3
      h1(5,6)=3*l*m*m*n*dd1+n*l*(1-4*m*m)*dd2+n*l*(m*m-1)*dd3
      h1(5,7)=3*l*l*m*n*dd1+m*n*(1-4*l*l)*dd2+m*n*(l*l-1)*dd3
      h1(5,8)=3*ha*l*m*(l*l-m*m)*dd1+2*l*m*(m*m-l*l)*dd2+
     #                                         ha*l*m*(l*l-m*m)*dd3
      h1(5,9)=sq3*l*m*(n*n-ha*(l*l+m*m))*dd1-2*sq3*l*m*n*n*dd2+
     #                                       ha*sq3*l*m*(1+n*n)*dd3
      h1(5,10)=sq3*l*m*wd1
c
      h1(6,1)=sq3*m*n*sd1
      h1(6,2)=-l*m*n*(sq3*pd1-2*pd2)
      h1(6,3)=-sq3*n*m*m*pd1-n*(1-2*m*m)*pd2
      h1(6,4)=-sq3*m*n*n*pd1-m*(1-2*n*n)*pd2
      h1(6,5)=3*l*m*m*n*dd1+n*l*(1-4*m*m)*dd2+n*l*(m*m-1)*dd3
      h1(6,6)=3*m*m*n*n*dd1+(m*m+n*n-4*m*m*n*n)*dd2+(l*l+m*m*n*n)*dd3
      h1(6,7)=3*l*m*n*n*dd1+l*m*(1-4*n*n)*dd2+l*m*(n*n-1)*dd3
      h1(6,8)=3*ha*m*n*(l*l-m*m)*dd1-m*n*(1+2*(l*l-m*m))*dd2+
     #                                     m*n*(1+ha*(l*l-m*m))*dd3
      h1(6,9)=sq3*m*n*(n*n-ha*(l*l+m*m))*dd1+sq3*m*n*(l*l+m*m-n*n)*dd2-
     #                                     ha*sq3*m*n*(l*l+m*m)*dd3
      h1(6,10)=sq3*m*n*wd1
c
      h1(7,1)=sq3*n*l*sd1
      h1(7,2)=-sq3*l*l*n*pd1-n*(1-2*l*l)*pd2
      h1(7,3)=-l*m*n*(sq3*pd1-2*pd2)
      h1(7,4)=-sq3*l*n*n*pd1-l*(1-2*n*n)*pd2
      h1(7,5)=3*l*l*m*n*dd1+m*n*(1-4*l*l)*dd2+m*n*(l*l-1)*dd3
      h1(7,6)=3*l*m*n*n*dd1+l*m*(1-4*n*n)*dd2+l*m*(n*n-1)*dd3
      h1(7,7)=3*l*l*n*n*dd1+(l*l+n*n-4*l*l*n*n)*dd2+(m*m+l*l*n*n)*dd3
      h1(7,8)=3*ha*n*l*(l*l-m*m)*dd1+n*l*(1-2*(l*l-m*m))*dd2-
     #                                     n*l*(1-ha*(l*l-m*m))*dd3
      h1(7,9)=sq3*n*l*(n*n-ha*(l*l+m*m))*dd1+sq3*n*l*(l*l+m*m-n*n)*dd2-
     #                                     ha*sq3*n*l*(l*l+m*m)*dd3
      h1(7,10)=sq3*n*l*wd1
c
      h1(8,1)=ha*sq3*(l*l-m*m)*sd1
      h1(8,2)=-ha*sq3*l*(l*l-m*m)*pd1-l*(1-l*l+m*m)*pd2
      h1(8,3)=-ha*sq3*m*(l*l-m*m)*pd1+m*(1+l*l-m*m)*pd2
      h1(8,4)=-ha*sq3*n*(l*l-m*m)*pd1+n*(l*l-m*m)*pd2
      h1(8,5)=3*ha*l*m*(l*l-m*m)*dd1+2*l*m*(m*m-l*l)*dd2+
     #                                         ha*l*m*(l*l-m*m)*dd3
      h1(8,6)=3*ha*m*n*(l*l-m*m)*dd1-m*n*(1+2*(l*l-m*m))*dd2+
     #                                     m*n*(1+ha*(l*l-m*m))*dd3
      h1(8,7)=3*ha*n*l*(l*l-m*m)*dd1+n*l*(1-2*(l*l-m*m))*dd2-
     #                                     n*l*(1-ha*(l*l-m*m))*dd3
      h1(8,8)=3*qu*((l*l-m*m)**2)*dd1+(l*l+m*m-((l*l-m*m)**2))*dd2+
     #                                  (n*n+qu*((l*l-m*m)**2))*dd3
      h1(8,9)=ha*sq3*(l*l-m*m)*(n*n-ha*(l*l+m*m))*dd1+
     #           sq3*n*n*(m*m-l*l)*dd2+qu*sq3*(1+n*n)*(l*l-m*m)*dd3
      h1(8,10)=ha*sq3*(l*l-m*m)*wd1
c
      h1(9,1)=(n*n-ha*(l*l+m*m))*sd1
      h1(9,2)=-l*(n*n-ha*(l*l+m*m))*pd1+sq3*l*n*n*pd2
      h1(9,3)=-m*(n*n-ha*(l*l+m*m))*pd1+sq3*m*n*n*pd2
      h1(9,4)=-n*(n*n-ha*(l*l+m*m))*pd1-sq3*n*(l*l+m*m)*pd2
      h1(9,5)=sq3*l*m*(n*n-ha*(l*l+m*m))*dd1-2*sq3*l*m*n*n*dd2+
     #                                       ha*sq3*l*m*(1+n*n)*dd3
      h1(9,6)=sq3*m*n*(n*n-ha*(l*l+m*m))*dd1+sq3*m*n*(l*l+m*m-n*n)*dd2-
     #                                     ha*sq3*m*n*(l*l+m*m)*dd3
      h1(9,7)=sq3*n*l*(n*n-ha*(l*l+m*m))*dd1+sq3*n*l*(l*l+m*m-n*n)*dd2-
     #                                     ha*sq3*n*l*(l*l+m*m)*dd3
      h1(9,8)=ha*sq3*(l*l-m*m)*(n*n-ha*(l*l+m*m))*dd1+
     #           sq3*n*n*(m*m-l*l)*dd2+qu*sq3*(1+n*n)*(l*l-m*m)*dd3
      h1(9,9)=((n*n-ha*(l*l+m*m))**2)*dd1+3*n*n*(l*l+m*m)*dd2+
     #                                      3*qu*((l*l+m*m)**2)*dd3
      h1(9,10)=(n*n-ha*(l*l+m*m))*wd1
c
      h1(10,1)=sw1
      h1(10,2)=l*wp1
      h1(10,3)=m*wp1
      h1(10,4)=n*wp1
      h1(10,5)=sq3*l*m*wd1
      h1(10,6)=sq3*m*n*wd1
      h1(10,7)=sq3*n*l*wd1
      h1(10,8)=ha*sq3*(l*l-m*m)*wd1
      h1(10,9)=(n*n-ha*(l*l+m*m))*wd1
      h1(10,10)=ww1
c
      end


! { dg-do compile }
! { dg-require-effective-target vect_float }
! { dg-additional-options "-O3 -fcray-pointer" }
! PR 32380 - loops were not vectorized due to unaligned store.
      subroutine trnfbt(e,f,qs,mte,gm,ihgenf,hgener,lft,llt,sthick,
     .                  fibl,istupd,ies,hoff)
      parameter (nlq=96)
      integer nnlq
      common/newnlq/nnlq
c   ... implicit common ...
      integer imauto,iteopt,lauto,mthsol,ilimit,maxref,icnvrg,
     & igdiv,nwebuf,neql,neqt,imterm,imphas,nbfgs,
     & numupd,istif,itrlas,imerr,imdof,neqtgl,lsmtd,lsdir
      common/bki01i/imauto,iteopt,lauto,mthsol,ilimit,maxref,icnvrg,
     & igdiv,nwebuf,neql,neqt,imterm,imphas,nbfgs,
     & numupd,istif,itrlas,imerr,imdof,neqtgl,lsmtd,lsdir
      REAL dtimp,dtimp0,timeim,dtmnim,dtmxim,cvtl,ectl,rctl,
     & tolls,dnorm2,dtprnt,dtplot,dtiter,dtrefm
      common/bki01r/dtimp,dtimp0,timeim,dtmnim,dtmxim,cvtl,ectl,rctl,
     & tolls,dnorm2,dtprnt(2),dtplot(2),dtiter(2),dtrefm(2)
      REAL ascntl
      common/bki02r/ascntl(150)
      logical lsensw
      common/bki01l/lsensw(20)
      integer imip,isolvr,icwrb
      common/bki02i/imip(100),isolvr(200),icwrb(50)
c   ... implicit common ...
c
c
c
      integer lnodim,ndofpn,nnpke,melemt,imlft,imllt,is17loc
      common/bki03iloc/lnodim(nlq,16),ndofpn,nnpke,melemt,imlft,imllt,
     &                 is17loc
      real*4 ske
      common/bki03rloc/ske(nlq,1176)
      integer lmke
      common/bki04iloc/lmke(nlq,48)
c******************************************************************
c|  livermore software technology corporation  (lstc)             |
c|  ------------------------------------------------------------  |
c|  copyright 1987,1988,1989 john o. hallquist, lstc              |
c|  all rights reserved                                           |
c******************************************************************
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
      common/bk12loc/b12,b2,qhg,qhgm,qhgb,qhgw
      common/aux00loc/
     & sig1m(nlq),sig2m(nlq),sig4m(nlq),sig1n(nlq),sig2n(nlq),
     & sig4n(nlq),sig5n(nlq),sig6n(nlq),sig5l(nlq),sig6l(nlq),
     & str33(nlq),enginc(nlq)
      common/aux01loc/
     &ft11(nlq),ft12(nlq),ft13(nlq),ft21(nlq),ft22(nlq),ft23(nlq),
     &fm11(nlq),fm12(nlq),fm21(nlq),fm22(nlq),
     &fm31(nlq),fm32(nlq),fm41(nlq),fm42(nlq),
     &fmr11(nlq),fmr12(nlq),fmr21(nlq),fmr22(nlq),fmr31(nlq),
     &fmr32(nlq),fmr41(nlq),fmr42(nlq),sg5(nlq),sg6(nlq)
      common/aux7loc/
     1 vx1(nlq),vx2(nlq),vx3(nlq),vx4(nlq),
     2 vx5(nlq),vx6(nlq),vx7(nlq),vx8(nlq),
     3 vy1(nlq),vy2(nlq),vy3(nlq),vy4(nlq),
     4 vy5(nlq),vy6(nlq),vy7(nlq),vy8(nlq),
     5 vz1(nlq),vz2(nlq),vz3(nlq),vz4(nlq),
     6 vz5(nlq),vz6(nlq),vz7(nlq),vz8(nlq)
      common/aux10loc/area(nlq),
     1 px1(nlq),px2(nlq),px3(nlq),px4(nlq),
     & px5(nlq),px6(nlq),px7(nlq),px8(nlq),
     2 py1(nlq),py2(nlq),py3(nlq),py4(nlq),
     & py5(nlq),py6(nlq),py7(nlq),py8(nlq),
     3 pz1(nlq),pz2(nlq),pz3(nlq),pz4(nlq),
     & pz5(nlq),pz6(nlq),pz7(nlq),pz8(nlq),
     4 dx1(nlq),dx2(nlq),dx3(nlq),dx4(nlq),
     5 dx5(nlq),dx6(nlq),dx7(nlq),dx8(nlq),
     6 dy1(nlq),dy2(nlq),dy3(nlq),dy4(nlq),
     7 dy5(nlq),dy6(nlq),dy7(nlq),dy8(nlq),
     8 dz1(nlq),dz2(nlq),dz3(nlq),dz4(nlq),
     9 dz5(nlq),dz6(nlq),dz7(nlq),dz8(nlq)
      common/aux11loc/
     &ft31(nlq),ft32(nlq),ft33(nlq),ft41(nlq),ft42(nlq),ft43(nlq),
     &htx(nlq),hty(nlq),gm1(nlq),gm2(nlq),gm3(nlq),gm4(nlq),
     &bsum(nlq),qhx(nlq),qhy(nlq),qwz(nlq),qtx(nlq),qty(nlq)
      real*4 mx1,my1,mz1,mx2,my2,mz2,mx3,my3,mz3,mx4,my4,mz4
      common/aux13loc/
     &zeta(nlq),thick(nlq),fga(nlq),fgb(nlq),fgc(nlq),
     &gl11(nlq),gl12(nlq),gl13(nlq),gl21(nlq),gl22(nlq),gl23(nlq),
     &gl31(nlq),gl32(nlq),gl33(nlq),
     &x1(nlq),y1(nlq),z1(nlq),x2(nlq),y2(nlq),z2(nlq),
     &x3(nlq),y3(nlq),z3(nlq),x4(nlq),y4(nlq),z4(nlq),
     &fx1(nlq),fy1(nlq),fz1(nlq),fx2(nlq),fy2(nlq),fz2(nlq),
     &fx3(nlq),fy3(nlq),fz3(nlq),fx4(nlq),fy4(nlq),fz4(nlq),
     &mx1(nlq),my1(nlq),mz1(nlq),mx2(nlq),my2(nlq),mz2(nlq),
     &mx3(nlq),my3(nlq),mz3(nlq),mx4(nlq),my4(nlq),mz4(nlq)
      common/aux33loc/
     1 ix1(nlq),ix2(nlq),ix3(nlq),ix4(nlq),ixs(nlq,4),mxt(nlq)
      common/aux35loc/rhoa(nlq),cxx(nlq),fcl(nlq),fcq(nlq)
      common/hourgloc/ymod(nlq),gmod(nlq),ifsv(nlq)
      common/soundloc/sndspd(nlq),sndsp(nlq),diagm(nlq),sarea(nlq),
     . dxl(nlq)
      common/bel6loc/bm(nlq,3,8),bb(nlq,3,8),bs(nlq,2,12),bhg(nlq,4),
     1 ex(nlq,3,8),dp0(nlq,3,3),dp1(nlq,3,3),dp2(nlq,3,3),
     2 ds(nlq),dhg(nlq,5)
c
      common/shlioc/ioshl(60)
      common/failuloc/sieu(nlq),fail(nlq),ifaili(nlq)
      logical output,slnew
      common/csforc/ncs1,ncs2,ncs3,ncs4,ncs5,ncs6,ncs7,ncs8,ncs9,
     1 ncs10,ncs11,ncs12,ncs13,ncs14,ncs15,
     1 numcsd,csdinc,csdout,output,slnew,future(8)
      common/csfsavloc/savfrc(nlq,24),svfail(nlq),ndof,ifail
      common/sorterloc/nnc,lczc
      common/sorter/znnc,zlczc,
     & ns11,ns12,ns13,ns14,ns15,ns16,
     & nh11,nh12,nh13,nh14,nh15,nh16,
     & nt11,nt12,nt13,nt14,nt15,nt16,
     & nb11,nb12,nb13,nb14,nb15,nb16,
     & nu11,nu12,nu13,nu14,nu15,nu16,
     & nd11,nd12,nd13,nd14,nd15,nd16
      common/subtssloc/dt1siz(nlq)
      common/matflr/mtfail(200)
      common/berwcmloc/xll(nlq),rigx(nlq),rigy(nlq)
      common /mem/ mp
      integer ia(1)
      pointer(mp,ia)
      real*4 mmode,ies
      dimension e(3,1),f(3,1),qs(9,1),gm(4,*),hgener(*)
      dimension qs1(nlq),qs2(nlq),qs3(nlq),qs4(nlq),qs5(nlq)
      dimension fibl(9,1),sthick(*),ies(*),hoff(*)
c
      ifail=0
      if (qhgb+qhgw+qhgm.gt.1.e-04) then
      tmode=qhgb*ymod(lft)/1920.0
      wmode=qhgw*gmod(lft)/120.00
      mmode=qhgm*ymod(lft)/80.000
c
      hgfac=rhoa(lft)*sndspd(lft)
c
      do i=lft,llt
      htxi  =area(i)*(x3(i)-x2(i)-x4(i))
      htyi  =area(i)*(y3(i)-y2(i)-y4(i))
      gm1(i)= 1.-px1(i)*htxi-py1(i)*htyi
      gm2(i)=-1.-px2(i)*htxi-py2(i)*htyi
      gm3(i)= 2.-gm1(i)
      gm4(i)=-2.-gm2(i)
      qhx(i)=gm2(i)*vx2(i)+gm3(i)*vx3(i)+gm4(i)*vx4(i)
      qhy(i)=gm2(i)*vy2(i)+gm3(i)*vy3(i)+gm4(i)*vy4(i)
      qwz(i)=gm2(i)*vz2(i)+gm3(i)*vz3(i)+gm4(i)*vz4(i)
      enddo
      do i=lft,llt
      c3=      sqrt(abs(sarea(i)))*thick(i)/(dt1siz(i)+1.e-16)
      c2=(hgfac*qhgw)*c3
      c1=(hgfac*qhgb*.01)*c3*thick(i)*thick(i)
      c3=(hgfac*qhgm)*c3
      qtx(i)=gm2(i)*vx6(i)+gm3(i)*vx7(i)+gm4(i)*vx8(i)
      qty(i)=gm2(i)*vy6(i)+gm3(i)*vy7(i)+gm4(i)*vy8(i)
      xll2  =2.*xll(i)
      qhxi  =qhx(i)+xll2*rigy(i)
      qhyi  =qhy(i)-xll2*rigx(i)
      qs1(i)=c3*qhxi
      qs2(i)=c3*qhyi
      qs3(i)=c2*qwz(i)
      qs4(i)=c1*qtx(i)
      qs5(i)=c1*qty(i)
      enddo
c
c
c
      if (isolvr(18).eq.0) then
c
      do i=lft,llt
      fm11(i)= fm11(i)+gm1(i)*qs4(i)
      fm12(i)= fm12(i)+gm1(i)*qs5(i)
      fm21(i)= fm21(i)+gm2(i)*qs4(i)
      fm22(i)= fm22(i)+gm2(i)*qs5(i)
      fm31(i)= fm31(i)+gm3(i)*qs4(i)
      fm32(i)= fm32(i)+gm3(i)*qs5(i)
      fm41(i)= fm41(i)+gm4(i)*qs4(i)
      fm42(i)= fm42(i)+gm4(i)*qs5(i)
      enddo
C
      else
c
      do 45 i=lft,llt
      ft31(i)=-ft11(i)+gm3(i)*qs1(i)
      ft32(i)=-ft12(i)+gm3(i)*qs2(i)
      ft33(i)=-ft13(i)+gm3(i)*qs3(i)
      ft41(i)=-ft21(i)+gm4(i)*qs1(i)
      ft42(i)=-ft22(i)+gm4(i)*qs2(i)
      ft43(i)=-ft23(i)+gm4(i)*qs3(i)
      ft11(i)= ft11(i)+gm1(i)*qs1(i)
      ft12(i)= ft12(i)+gm1(i)*qs2(i)
      ft13(i)= ft13(i)+gm1(i)*qs3(i)
      ft21(i)= ft21(i)+gm2(i)*qs1(i)
      ft22(i)= ft22(i)+gm2(i)*qs2(i)
      ft23(i)= ft23(i)+gm2(i)*qs3(i)
      fm11(i)= fm11(i)+gm1(i)*qs4(i)
      fm12(i)= fm12(i)+gm1(i)*qs5(i)
      fm21(i)= fm21(i)+gm2(i)*qs4(i)
      fm22(i)= fm22(i)+gm2(i)*qs5(i)
      fm31(i)= fm31(i)+gm3(i)*qs4(i)
      fm32(i)= fm32(i)+gm3(i)*qs5(i)
      fm41(i)= fm41(i)+gm4(i)*qs4(i)
      fm42(i)= fm42(i)+gm4(i)*qs5(i)
   45 continue
      endif
c
      else
c
      do 40 i=lft,llt
      ft31(i)=-ft11(i)
      ft32(i)=-ft12(i)
      ft33(i)=-ft13(i)
      ft41(i)=-ft21(i)
      ft42(i)=-ft22(i)
      ft43(i)=-ft23(i)
   40 continue
      endif
c
c
      do i=lft,llt
      mz1(i)=gl31(i)*fm11(i)+gl32(i)*fm12(i)
      mz2(i)=gl31(i)*fm21(i)+gl32(i)*fm22(i)
      fz1(i)=gl31(i)*ft11(i)+gl32(i)*ft12(i)+gl33(i)*ft13(i)
      fz2(i)=gl31(i)*ft21(i)+gl32(i)*ft22(i)+gl33(i)*ft23(i)
      mz3(i)=gl31(i)*fm31(i)+gl32(i)*fm32(i)
      mz4(i)=gl31(i)*fm41(i)+gl32(i)*fm42(i)
      fz3(i)=gl31(i)*ft31(i)+gl32(i)*ft32(i)+gl33(i)*ft33(i)
      fz4(i)=gl31(i)*ft41(i)+gl32(i)*ft42(i)+gl33(i)*ft43(i)
      enddo
   90 continue
c
      if (output) then
      do i=lft,llt
      savfrc(i, 1)= fx1(i)
      savfrc(i, 2)= fy1(i)
      enddo
c
      ndof=4
      if (ifail.eq.1) then
        do i=lft,llt
        svfail(i)=fail(i)
        enddo
      endif
      endif
c
      return
      end

! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { target { ! vect_element_align } } } }
! { dg-final { scan-tree-dump-times "vectorized 5 loops" 1 "vect" { target { vect_element_align && { ! vect_call_sqrtf } } } } }
! { dg-final { scan-tree-dump-times "vectorized 6 loops" 1 "vect" { target { vect_element_align && vect_call_sqrtf } } } }