      SUBROUTINE extract(I,J,NHW,NHE,NVN,NVS)
C
C     THIS SUBROUTINE AGGREGATES ALL SOIL-PLANT C,N,P EXCHANGES
C     FROM 'UPTAKE' AMD 'GROSUB' AND SENDS RESULTS TO 'REDIST'
C
      include "parameters.h"
      include "blkc.h"
      include "blk1cp.h"
      include "blk1cr.h"
      include "blk1g.h"
      include "blk1n.h"
      include "blk1p.h"
      include "blk2a.h"
      include "blk2b.h"
      include "blk2c.h"
      include "blk3.h"
      include "blk8a.h"
      include "blk8b.h"
      include "blk9a.h"
      include "blk9b.h"
      include "blk9c.h"
      include "blk11a.h"
      include "blk11b.h"
      include "blk12a.h"
      include "blk12b.h"
      include "blk13c.h"
      include "blk14.h"
      include "blk16.h"
      include "blk18a.h"
      include "blk18b.h"
      DO 9995 NX=NHW,NHE
      DO 9990 NY=NVN,NVS
      DO 9985 NZ=1,NP0(NY,NX)
C
C     TOTAL LITTERFALL OF ALL PLANT SPECIES
C
C     ZCSNC,ZZSNC,ZPSNC=total C,N,P litterfall
C     HCSNC,HZSNC,HPSNC=hourly PFT C,N,P litterfall from grosub.f
C     WTSTGT=total standing dead C,N,P mass
C     WTSTG=PFT standing dead C,N,P mass
C     CSNC,ZSNC,PSNC=cumulative PFT C,N,P litterfall from grosub.f
C     CSNT,ZSNT,PSNT=cumulative total C,N,P litterfall
C
      ZCSNC(NY,NX)=ZCSNC(NY,NX)+HCSNC(NZ,NY,NX)
      ZZSNC(NY,NX)=ZZSNC(NY,NX)+HZSNC(NZ,NY,NX)
      ZPSNC(NY,NX)=ZPSNC(NY,NX)+HPSNC(NZ,NY,NX)
      WTSTGT(NY,NX)=WTSTGT(NY,NX)+WTSTG(NZ,NY,NX)
      DO 90 L=0,NI(NZ,NY,NX)
      DO 95 K=0,1
      DO 95 M=1,4
      CSNT(M,K,L,NY,NX)=CSNT(M,K,L,NY,NX)+CSNC(M,K,L,NZ,NY,NX)
      ZSNT(M,K,L,NY,NX)=ZSNT(M,K,L,NY,NX)+ZSNC(M,K,L,NZ,NY,NX)
      PSNT(M,K,L,NY,NX)=PSNT(M,K,L,NY,NX)+PSNC(M,K,L,NZ,NY,NX)
95    CONTINUE
90    CONTINUE
9985  CONTINUE
      ARLFC(NY,NX)=0.0
      ARSTC(NY,NX)=0.0
      DO 915 L=1,JC
      ARLFT(L,NY,NX)=0.0
      WGLFT(L,NY,NX)=0.0
      ARSTT(L,NY,NX)=0.0
915   CONTINUE
      DO 9975 NZ=1,NP(NY,NX)
      IF(IFLGC(NZ,NY,NX).EQ.1)THEN
C
C     TOTAL LEAF AREA OF ALL PLANT SPECIES
C
C     ARLFT,ARSTT=total leaf,stalk area of combined canopy layer
C     ARLFV,ARSTV=PFT leaf,stalk area in canopy layer
C     WGLFT=total leaf C of combined canopy layer
C     WGLFV=PFT leaf C in canopy layer
C
      DO 910 L=1,JC
      ARLFT(L,NY,NX)=ARLFT(L,NY,NX)+ARLFV(L,NZ,NY,NX)
      WGLFT(L,NY,NX)=WGLFT(L,NY,NX)+WGLFV(L,NZ,NY,NX)
      ARSTT(L,NY,NX)=ARSTT(L,NY,NX)+ARSTV(L,NZ,NY,NX)
910   CONTINUE
C
C     TOTAL GAS AND SOLUTE UPTAKE BY ALL PLANT SPECIES
C
      DO 100 N=1,MY(NZ,NY,NX)
      DO 100 L=NU(NY,NX),NI(NZ,NY,NX)
C
C     TOTAL ROOT DENSITY
C
C     RTDNT=total root length density
C     RTDNP=PFT root length density per plant
C     UPWTR=total water uptake
C     UPWTR=PFT root water uptake
C     TUPHT=total convective heat in root water uptake
C     TKS=soil temperature
C     PP=PFT population
C
      IF(N.EQ.1)THEN
      RTDNT(L,NY,NX)=RTDNT(L,NY,NX)+RTDNP(N,L,NZ,NY,NX)
     2*PP(NZ,NY,NX)/AREA(3,L,NY,NX)
      ENDIF
C
C     TOTAL WATER UPTAKE
C
      TUPWTR(L,NY,NX)=TUPWTR(L,NY,NX)+UPWTR(N,L,NZ,NY,NX)
      TUPHT(L,NY,NX)=TUPHT(L,NY,NX)+UPWTR(N,L,NZ,NY,NX)
     2*4.19*TKS(L,NY,NX)
C
C     ROOT GAS CONTENTS FROM FLUXES IN 'UPTAKE'
C
C     *A,*P=PFT root gaseous, aqueous gas content
C     gas code:CO=CO2,OX=O2,CH=CH4,N2=N2O,NH=NH3,H2=H2
C     R*FLA=root gaseous-atmosphere CO2 exchange
C     R*DFA=root aqueous-gaseous CO2 exchange
C
      CO2A(N,L,NZ,NY,NX)=CO2A(N,L,NZ,NY,NX)+RCOFLA(N,L,NZ,NY,NX)
     2-RCODFA(N,L,NZ,NY,NX)
      OXYA(N,L,NZ,NY,NX)=OXYA(N,L,NZ,NY,NX)+ROXFLA(N,L,NZ,NY,NX)
     2-ROXDFA(N,L,NZ,NY,NX)
      CH4A(N,L,NZ,NY,NX)=CH4A(N,L,NZ,NY,NX)+RCHFLA(N,L,NZ,NY,NX)
     2-RCHDFA(N,L,NZ,NY,NX)
      Z2OA(N,L,NZ,NY,NX)=Z2OA(N,L,NZ,NY,NX)+RN2FLA(N,L,NZ,NY,NX)
     2-RN2DFA(N,L,NZ,NY,NX)
      ZH3A(N,L,NZ,NY,NX)=ZH3A(N,L,NZ,NY,NX)+RNHFLA(N,L,NZ,NY,NX)
     2-RNHDFA(N,L,NZ,NY,NX)
      H2GA(N,L,NZ,NY,NX)=H2GA(N,L,NZ,NY,NX)+RHGFLA(N,L,NZ,NY,NX)
     2-RHGDFA(N,L,NZ,NY,NX)
      CO2P(N,L,NZ,NY,NX)=CO2P(N,L,NZ,NY,NX)+RCODFA(N,L,NZ,NY,NX)
     2+RCO2P(N,L,NZ,NY,NX)
      OXYP(N,L,NZ,NY,NX)=OXYP(N,L,NZ,NY,NX)+ROXDFA(N,L,NZ,NY,NX)
     2-RUPOXP(N,L,NZ,NY,NX)
      CH4P(N,L,NZ,NY,NX)=CH4P(N,L,NZ,NY,NX)+RCHDFA(N,L,NZ,NY,NX)
     2+RUPCHS(N,L,NZ,NY,NX)
      Z2OP(N,L,NZ,NY,NX)=Z2OP(N,L,NZ,NY,NX)+RN2DFA(N,L,NZ,NY,NX)
     2+RUPN2S(N,L,NZ,NY,NX)
      ZH3P(N,L,NZ,NY,NX)=ZH3P(N,L,NZ,NY,NX)+RNHDFA(N,L,NZ,NY,NX)
     2+RUPN3S(N,L,NZ,NY,NX)+RUPN3B(N,L,NZ,NY,NX)
      H2GP(N,L,NZ,NY,NX)=H2GP(N,L,NZ,NY,NX)+RHGDFA(N,L,NZ,NY,NX)
     2+RUPHGS(N,L,NZ,NY,NX)
C
C     TOTAL ROOT GAS CONTENTS
C
C     TL*P=total root gas content
C     *A,*P=PFT root gaseous, aqueous gas content
C
      TLCO2P(L,NY,NX)=TLCO2P(L,NY,NX)+CO2P(N,L,NZ,NY,NX)
     2+CO2A(N,L,NZ,NY,NX)
      TLOXYP(L,NY,NX)=TLOXYP(L,NY,NX)+OXYP(N,L,NZ,NY,NX)
     2+OXYA(N,L,NZ,NY,NX)
      TLCH4P(L,NY,NX)=TLCH4P(L,NY,NX)+CH4P(N,L,NZ,NY,NX)
     2+CH4A(N,L,NZ,NY,NX)
      TLN2OP(L,NY,NX)=TLN2OP(L,NY,NX)+Z2OP(N,L,NZ,NY,NX)
     2+Z2OA(N,L,NZ,NY,NX)
      TLNH3P(L,NY,NX)=TLNH3P(L,NY,NX)+ZH3P(N,L,NZ,NY,NX)
     2+ZH3A(N,L,NZ,NY,NX)
      TLH2GP(L,NY,NX)=TLH2GP(L,NY,NX)+H2GP(N,L,NZ,NY,NX)
     2+H2GA(N,L,NZ,NY,NX)
C     IF(NX.EQ.1.AND.NY.EQ.1)THEN
C     WRITE(*,5566)'TLOXYP',I,J,NX,NY,NZ,L,N
C    2,TLOXYP(L,NY,NX),OXYP(N,L,NZ,NY,NX),OXYA(N,L,NZ,NY,NX)
C    3,ROXDFA(N,L,NZ,NY,NX),RUPOXP(N,L,NZ,NY,NX),ROXFLA(N,L,NZ,NY,NX)
C    4,TLCO2P(L,NY,NX),CO2P(N,L,NZ,NY,NX),CO2A(N,L,NZ,NY,NX)
C    5,RCODFA(N,L,NZ,NY,NX),RCO2P(N,L,NZ,NY,NX)
C    6,RCO2S(N,L,NZ,NY,NX)
C    4,TLCH4P(L,NY,NX),CH4P(N,L,NZ,NY,NX),CH4A(N,L,NZ,NY,NX)
C    5,RCHDFA(N,L,NZ,NY,NX),RUPCHS(N,L,NZ,NY,NX),RCHFLA(N,L,NZ,NY,NX)
5566  FORMAT(A8,7I4,20E12.4)
C     ENDIF
C
C     TOTAL ROOT BOUNDARY GAS FLUXES
C
C     T*FLA=total root gaseous-atmosphere CO2 exchange
C     R*FLA=PFT root gaseous-atmosphere CO2 exchange
C     gas code:CO=CO2,OX=O2,CH=CH4,N2=N2O,NH=NH3,H2=H2
C     TUP*S,TUP*B=total root-soil gas, solute exchange in non-band,band
C     RUP*S,RUP*B*=PFT root-soil gas, solute exchange in non-band,band
C     gas code:CO=CO2,OX=O2,CH=CH4,N2=N2O,NH=NH3,H2=H2
C     solute code:NH4=NH4,NO3=NO3,H2P=H2PO4,H1P=H1PO4 in non-band
C                :NHB=NH4,NOB=NO3,H2B=H2PO4,H1B=H1PO4 in band
C
      TCOFLA(L,NY,NX)=TCOFLA(L,NY,NX)+RCOFLA(N,L,NZ,NY,NX)
      TOXFLA(L,NY,NX)=TOXFLA(L,NY,NX)+ROXFLA(N,L,NZ,NY,NX)
      TCHFLA(L,NY,NX)=TCHFLA(L,NY,NX)+RCHFLA(N,L,NZ,NY,NX)
      TN2FLA(L,NY,NX)=TN2FLA(L,NY,NX)+RN2FLA(N,L,NZ,NY,NX)
      TNHFLA(L,NY,NX)=TNHFLA(L,NY,NX)+RNHFLA(N,L,NZ,NY,NX)
      THGFLA(L,NY,NX)=THGFLA(L,NY,NX)+RHGFLA(N,L,NZ,NY,NX)
      TCO2P(L,NY,NX)=TCO2P(L,NY,NX)-RCO2P(N,L,NZ,NY,NX)
      TUPOXP(L,NY,NX)=TUPOXP(L,NY,NX)+RUPOXP(N,L,NZ,NY,NX)
      TCO2S(L,NY,NX)=TCO2S(L,NY,NX)+RCO2S(N,L,NZ,NY,NX)
      TUPOXS(L,NY,NX)=TUPOXS(L,NY,NX)+RUPOXS(N,L,NZ,NY,NX)
      TUPCHS(L,NY,NX)=TUPCHS(L,NY,NX)+RUPCHS(N,L,NZ,NY,NX)
      TUPN2S(L,NY,NX)=TUPN2S(L,NY,NX)+RUPN2S(N,L,NZ,NY,NX)
      TUPN3S(L,NY,NX)=TUPN3S(L,NY,NX)+RUPN3S(N,L,NZ,NY,NX)
      TUPN3B(L,NY,NX)=TUPN3B(L,NY,NX)+RUPN3B(N,L,NZ,NY,NX)
      TUPHGS(L,NY,NX)=TUPHGS(L,NY,NX)+RUPHGS(N,L,NZ,NY,NX)
      TUPNH4(L,NY,NX)=TUPNH4(L,NY,NX)+RUPNH4(N,L,NZ,NY,NX)
      TUPNO3(L,NY,NX)=TUPNO3(L,NY,NX)+RUPNO3(N,L,NZ,NY,NX)
      TUPH2P(L,NY,NX)=TUPH2P(L,NY,NX)+RUPH2P(N,L,NZ,NY,NX)
      TUPH1P(L,NY,NX)=TUPH1P(L,NY,NX)+RUPH1P(N,L,NZ,NY,NX)
      TUPNHB(L,NY,NX)=TUPNHB(L,NY,NX)+RUPNHB(N,L,NZ,NY,NX)
      TUPNOB(L,NY,NX)=TUPNOB(L,NY,NX)+RUPNOB(N,L,NZ,NY,NX)
      TUPH2B(L,NY,NX)=TUPH2B(L,NY,NX)+RUPH2B(N,L,NZ,NY,NX)
      TUPH1B(L,NY,NX)=TUPH1B(L,NY,NX)+RUPH1B(N,L,NZ,NY,NX)
C     IF(NY.EQ.5.AND.L.EQ.1)THEN
C     WRITE(*,4141)'TCO2S',I,J,NX,NY,L,NZ,N,TCO2S(L,NY,NX)
C    2,RCO2S(N,L,NZ,NY,NX),TCO2P(L,NY,NX),RCO2P(N,L,NZ,NY,NX)
C     WRITE(*,4141)'TUPOX',I,J,NX,NY,L,NZ,N,TUPOXS(L,NY,NX)
C    2,RUPOXS(N,L,NZ,NY,NX),TUPOXP(L,NY,NX),RUPOXP(N,L,NZ,NY,NX)
C     WRITE(*,4141)'TCHFLA',I,J,NX,NY,L,NZ,N,TCHFLA(L,NY,NX)
C    2,RCHFLA(N,L,NZ,NY,NX),RUPCHS(N,L,NZ,NY,NX)
C     WRITE(*,4141)'TUPN2S',I,J,NX,NY,L,NZ,N,TUPN2S(L,NY,NX)
C    2,RUPN2S(N,L,NZ,NY,NX)
4141  FORMAT(A8,7I4,12E12.4)
C     ENDIF
C
C     TOTAL ROOT C,N,P EXUDATION
C
C     TDFOMC,TDFOMN,TDFOMP=total nonstructl C,N,P exchange
C     RDFOMC,RDFOMN,RDFOMP=PFT nonstructl C,N,P exchange
C
      DO 195 K=0,4
      TDFOMC(K,L,NY,NX)=TDFOMC(K,L,NY,NX)-RDFOMC(N,K,L,NZ,NY,NX)
      TDFOMN(K,L,NY,NX)=TDFOMN(K,L,NY,NX)-RDFOMN(N,K,L,NZ,NY,NX)
      TDFOMP(K,L,NY,NX)=TDFOMP(K,L,NY,NX)-RDFOMP(N,K,L,NZ,NY,NX)
195   CONTINUE
C
C     TOTAL ROOT O2, NH4, NO3, PO4 UPTAKE CONTRIBUTES TO
C     TOTAL ROOT + MICROBIAL UPTAKE USED TO CALCULATE
C     COMPETITION CONSTRAINTS
C
C     ROXYX=O2 demand by all microbial,root,myco populations
C     RNH4X=NH4 demand in non-band by all microbial,root,myco populations
C     RNO3X=NO3 demand in non-band by all microbial,root,myco populations
C     RPO4X=H2PO4 demand in non-band by all microbial,root,myco populations
C     RP14X=HPO4 demand in non-band by all microbial,root,myco populations
C     RNHBX=NH4 demand in band by all microbial,root,myco populations
C     RN3BX=NO3 demand in band by all microbial,root,myco populations
C     RPOBX=H2PO4 demand in band by all microbial,root,myco populations
C     RP1BX=HPO4 demand in band by all microbial,root,myco populations
C     ROXYP=O2 demand by each root,myco population
C     RUNNHP=NH4 demand in non-band by each root population
C     RUNNOP=NO3 demand in non-band by each root population
C     RUPP2P=H2PO4 demand in non-band by each root population
C     RUPP1P=HPO4 demand in non-band by each root population
C     RUNNBP=NH4 demand in band by each root population
C     RUNNXB=NO3 demand in band by each root population
C     RUPP2B=H2PO4 demand in band by each root population
C     RUPP1B=HPO4 demand in band by each root population
C
      ROXYX(L,NY,NX)=ROXYX(L,NY,NX)+ROXYP(N,L,NZ,NY,NX)
      RNH4X(L,NY,NX)=RNH4X(L,NY,NX)+RUNNHP(N,L,NZ,NY,NX)
      RNO3X(L,NY,NX)=RNO3X(L,NY,NX)+RUNNOP(N,L,NZ,NY,NX)
      RPO4X(L,NY,NX)=RPO4X(L,NY,NX)+RUPP2P(N,L,NZ,NY,NX)
      RP14X(L,NY,NX)=RP14X(L,NY,NX)+RUPP1P(N,L,NZ,NY,NX)
      RNHBX(L,NY,NX)=RNHBX(L,NY,NX)+RUNNBP(N,L,NZ,NY,NX)
      RN3BX(L,NY,NX)=RN3BX(L,NY,NX)+RUNNXP(N,L,NZ,NY,NX)
      RPOBX(L,NY,NX)=RPOBX(L,NY,NX)+RUPP2B(N,L,NZ,NY,NX)
      RP1BX(L,NY,NX)=RP1BX(L,NY,NX)+RUPP1B(N,L,NZ,NY,NX)
100   CONTINUE
C     IF(ISALTG.NE.0)THEN
C     XZHYS(L,NY,NX)=XZHYS(L,NY,NX)
C    2+0.0714*(TUPNH4(L,NY,NX)+TUPNHB(L,NY,NX))
C    3-0.0714*(TUPNO3(L,NY,NX)+TUPNOB(L,NY,NX))
C     ENDIF
C
C     TOTAL ROOT N2 FIXATION BY ALL PLANT SPECIES
C
C     TUPNF=total root N2 fixation
C     RUPNF=PFT root N2 fixation
C
      DO 85 L=NU(NY,NX),NI(NZ,NY,NX)
      TUPNF(L,NY,NX)=TUPNF(L,NY,NX)+RUPNF(L,NZ,NY,NX)
85    CONTINUE
C
C     TOTAL ENERGY, WATER, CO2 FLUXES
C
C     TRN=total net SW+LW absorbed by canopy
C     RAD1=PFT net SW+LW absorbed by canopy
C     TLE=total canopy latent heat flux
C     EFLXC=PFT canopy latent heat flux
C     TSH=total canopy sensible heat flux
C     SFLXC=PFT canopy sensible heat flux
C     TGH=total canopy storage heat flux
C     HFLXC=PFT canopy storage heat flux
C     TCCAN=total net CO2 fixation
C     CNET=PFT net CO2 fixation
C     TVOLWP,TVOLWC=total water volume in canopy,on canopy surfaces
C     VOLWP,VOLWC=PFT water volume in canopy,on canopy surfaces
C     TEVAPP,TEVAPC=total water flux to,from canopy,canopy surfaces
C     EVAPC,EP=water flux to,from canopy surfaces, inside canopy
C     TENGYC=total canopy water heat content
C     ENGYC=PFT canopy water heat content
C     ARLFC,ARSTC=total leaf,stalk area
C     ARLFP,ARSTP=PFT leaf,stalk area
C     ZCSNC,ZZSNC,ZPSNC=total net root-soil C,N,P exchange
C     HCUPTK,HZUPTK,HPUPTK=PFT net root-soil C,N,P exchange
C     TBALC,TBALN,TBALP=total C,N,P balance
C     BALC,BALN,BALP=PFT C,N,P balance
C     TCO2Z,TOXYZ,TCH4Z,TN2OZ,TNH3Z,TH2GZ=total loss of root CO2, O2, CH4, N2O, NH3, H2
C     RCO2Z,ROXYZ,RCH4Z,RN2OZ,RNH3Z,RH2GZ=PFT loss of root CO2, O2, CH4, N2O, NH3, H2
C
      TRN(NY,NX)=TRN(NY,NX)+RAD1(NZ,NY,NX)
      TLE(NY,NX)=TLE(NY,NX)+EFLXC(NZ,NY,NX)
      TSH(NY,NX)=TSH(NY,NX)+SFLXC(NZ,NY,NX)
      TGH(NY,NX)=TGH(NY,NX)+HFLXC(NZ,NY,NX)
      TCCAN(NY,NX)=TCCAN(NY,NX)+CNET(NZ,NY,NX)
      CTRAN(NZ,NY,NX)=CTRAN(NZ,NY,NX)+EP(NZ,NY,NX)+EVAPC(NZ,NY,NX)
      TVOLWP(NY,NX)=TVOLWP(NY,NX)+VOLWP(NZ,NY,NX)
      TVOLWC(NY,NX)=TVOLWC(NY,NX)+VOLWC(NZ,NY,NX)
      TEVAPP(NY,NX)=TEVAPP(NY,NX)+EP(NZ,NY,NX)+EVAPC(NZ,NY,NX)
      TEVAPC(NY,NX)=TEVAPC(NY,NX)+EVAPC(NZ,NY,NX)
      ENGYC=4.19*(VOLWC(NZ,NY,NX)+FLWC(NZ,NY,NX)+EVAPC(NZ,NY,NX))
     2*TKC(NZ,NY,NX)
      TENGYC(NY,NX)=TENGYC(NY,NX)+ENGYC
      THFLXC(NY,NX)=THFLXC(NY,NX)+ENGYC-ENGYX(NZ,NY,NX)
     2-(FLWC(NZ,NY,NX)*4.19*TKA(NY,NX))
      ENGYX(NZ,NY,NX)=ENGYC
      THRMC(NY,NX)=THRMC(NY,NX)+THRM1(NZ,NY,NX)
      ARLFC(NY,NX)=ARLFC(NY,NX)+ARLFP(NZ,NY,NX)
      ARSTC(NY,NX)=ARSTC(NY,NX)+ARSTP(NZ,NY,NX)
      ZCSNC(NY,NX)=ZCSNC(NY,NX)-HCUPTK(NZ,NY,NX)
      ZZSNC(NY,NX)=ZZSNC(NY,NX)-HZUPTK(NZ,NY,NX)
      ZPSNC(NY,NX)=ZPSNC(NY,NX)-HPUPTK(NZ,NY,NX)
      TBALC=TBALC+BALC(NZ,NY,NX)
      TBALN=TBALN+BALN(NZ,NY,NX)
      TBALP=TBALP+BALP(NZ,NY,NX)
      TCO2Z(NY,NX)=TCO2Z(NY,NX)+RCO2Z(NZ,NY,NX)
      TOXYZ(NY,NX)=TOXYZ(NY,NX)+ROXYZ(NZ,NY,NX)
      TCH4Z(NY,NX)=TCH4Z(NY,NX)+RCH4Z(NZ,NY,NX)
      TN2OZ(NY,NX)=TN2OZ(NY,NX)+RN2OZ(NZ,NY,NX)
      TNH3Z(NY,NX)=TNH3Z(NY,NX)+RNH3Z(NZ,NY,NX)
      TH2GZ(NY,NX)=TH2GZ(NY,NX)+RH2GZ(NZ,NY,NX)
C
C     TOTAL CANOPY NH3 EXCHANGE AND EXUDATION
C
C     RNH3B,RNH3C=PFT NH3 flux between atmosphere and branch,canopy
C     TNH3C=total NH3 flux between atmosphere and canopy
C
      RNH3C(NZ,NY,NX)=0.0
      DO 80 NB=1,NBR(NZ,NY,NX)
      RNH3C(NZ,NY,NX)=RNH3C(NZ,NY,NX)+RNH3B(NB,NZ,NY,NX)
      TNH3C(NZ,NY,NX)=TNH3C(NZ,NY,NX)+RNH3B(NB,NZ,NY,NX)
80    CONTINUE
      ENDIF
9975  CONTINUE
9990  CONTINUE
9995  CONTINUE
      RETURN
      END


!*************************************************************************
!>
!  The main common block for the package.

    module divamc_module

    use diva_constants

    implicit none

    public

    integer  :: icf !! Final index for current loop in DIVACR.  Required by
                    !! option 18.
    integer  :: ics !! Starting index for current loop in DIVACR.
    integer  :: idat(6) !! Used to store integer for error messages.  (Also used
                        !! in DIVAA for temporary storage of KORD(2).  (Local array in DIVAIN.)
    integer  :: igflg !! Used primarily in DIVAg, but also used in DIVA to keep
                      !! track of the state of GSTOP calculations:
                      !!
                      !!  * -2 Extrapolatory G's initialized, but not the interpolatory.
                      !!  * -1 Interpolatory G's initialized, but not the extrapolatory.
                      !!  *  0 Set when integration is started or restarted, or option setting GSTOP is set.
                      !!  *  1 Iterating to find a GSTOP.
                      !!  *  2 User told that a GSTOP was found.
                      !!  *  3 Checking G's at point where a GSTOP was located.
                      !!  *  4 Checking G's at a T output point.
                      !!  *  5 Usual case, no sign change detected.
    integer  :: igflgs !! used in [[DIVAG]]. Equivalenced to `itolep`
    integer  :: igstop(2) !! IGSTOP(k) is set in DIVAg to the index of the last G
                          !! with a 0, where k is one for an interpolatory G-Stop, and k is two
                          !! for an extrapolatory G-Stop.
    integer  :: igtype(2) !! Array with two elements as for IGSTOP, but this saves
                          !! a flag giving the nature of convergence to the stop:
                          !!
                          !!  * 0  All known G-stops completely processed.
                          !!  * 4  Need to compute next value while iterating.
                          !!  * 5  Got good convergence.
                          !!  * 6  Got convergence, but not to desired accuracy.
                          !!  * 7  Problem in getting convergence.
                          !!  * 8  A fatal error of some type.
    integer  :: ilgrep !! Used when correction to keep track of equations that
                       !! are to use a certain error tolerance.
    integer  :: ings !! Current index for G-stop being examined in DIVAG.
    integer  :: iop10 !! Number of times diagnostic output is to be given when
                      !! leaving DIVAcr (the corrector).
    integer  :: iop11 !! Gives current step number of the method.  Tells how
                      !! many of certain coefficients must be computed. (Has nothing to do
                      !! with options.) = min(max integ order + 1, KDIM).  Also set when
                      !! starting to flag that certain memory locations must be set to 0.
    integer  :: iop12 !! Points to location in F() where user supplied values
                      !! of HINC, HDEC, HMIN, and HMAX.  (0 if option 12 not used.)
    integer  :: iop13 !! If not zero, reverse communication will be used for
                      !! getting the values of derivatives.  Associated with option 13.
    integer  :: iop14 !! If not zero, reverse communication will be used in
                      !! place of calls to the output routine.  Associated with option 14.
    integer  :: iop15 !! If not zero, a return will be made to the user after
                      !! the initialization.  Associated with option 15.  This might be used
                      !! to overlay DIVA, some of the user's code, and perhaps DIVAop.
    integer  :: iop16 !! Points to location in KORD() where information for
                      !! specifying the error tolerance is specified.  See option 16.
    integer  :: iop17 !! Used in initialization for option 17, afterwards this
                      !! cell is used by KEXIT which is equivalenced to IOP17.
    integer  :: iop18 !! Points to location in KORD() where information for
                      !! specifying a grouping of equations for derivative evaluation is
                      !! stored.  See option 18.
    integer  :: iop19 !! Points to location in KORD() where information for
                      !! specifying a grouping of equations for integration order control
                      !! is stored.  See option 19.
    integer  :: iop20 !! Used for option 20, gives first location in F where
                      !! estimated errors are to be stored.  Expected to be useful in a
                      !! program for solving boundary value problems using multiple shooting.
    integer  :: iop21 !! Was used for stiff equations option (never completely
                      !! coded).  The optional code still uses this (don't activate it!).
                      !! Now used to flag the location if F where the user has stored the
                      !! tolerance to use in finding G-Stops.
    integer  :: iop21s !! Was used for stiff equations see above.
    integer  :: iop22 !! Set aside for possible option for stiff equations.
    integer  :: iop3 !! Value set by option 3:
                     !!
                     !!  *  0 Interpolate to final point. (The default)
                     !!  *  1 Integrate to final point.
                     !!  * -1 Extrapolate to final point.
    integer  :: iop4 !! Value set by option 4.  The output routine is called
                     !! with KORD(1) = 4, every IOP4 steps.  (Default value for IOP4 is a
                     !! very large number.
    integer  :: iop5 !! Value provided by option 5, used to specify extra
                     !! output points.
    integer  :: iop6 !! Value provided by option 6.  If nonzero, the output
                     !! routine is called at the end of every step.  If > 0, there are
                     !! IOP6 interpolating G-Stops.
    integer  :: iop7 !! Value provided by option 7.  If > 0, there are K7
                     !! extrapolating G-Stops.
    integer  :: iop8 !! Value provided by option 8.  If nonzero, the output
                     !! routine is called with KORD(1)=8 whenever the step size is changed.
    integer  :: iop9 !! Value provided by option 9.  Used to specify that the
                     !! user wishes to save the solution.
    integer  :: ioptc(23) !! In DIVAOP equivalenced so that IOPTC(3) is equivalent
                          !! to IOP3.
    integer  :: itolep !! Used for temporary storage, and for the index of a
                       !! tolerance relative to the start of tolerances.
    integer  :: ivc2(65) !! Array used for output of variables ICF to NY in
                         !! common block DIVAMC.
    integer  :: iy !! Used for the current index to the Y() array.  (Local
                   !! variable in DIVAIN used in computing IYI.)  Equivalenced to
                   !! IZFLAG in DIVAG.
    integer  :: izflag !! Equivalenced to IY.  Set to 0 initially, and later
                       !! set to the value returned by DZERO.
                       !!
                       !!  *  0  Value set on entry at start of search.
                       !!  *  1  Compute next g again.
                       !!  *  2  Normal terminiation.
                       !!  *  3  Normal termination -- error criterion not satisfied.
                       !!  *  4  Apparent discontinuity -- no zero found.
                       !!  *  5  Couldn't find a sign change.
                       !!  *  6  DZERO was called with a bad value in IZFLAG.
    integer  :: kemax !! Index associated with equation giving the largest
                      !! value for (estimated error) / (requested error).
    integer  :: kexit !! Equivalenced to IOP17 which is not used after
                      !! initialization.  Defines actions when KORD2I = -7.
                      !! (Referenced in (DIVAA,DA,G).).
                      !!
                      !!  * 1  Take the step over with reduced H.
                      !!  * 2  Take the step over.
                      !!  * 3  Do the end of step call to OUTPUT.
                      !!  * 4  Reset TMARK, then do same as for KEXIT = 2.
                      !!  * 5  Reset TMARK, then do same as for KEXIT = 3.
                      !!  * 6  Give the fatal error diagnostic.
    integer  :: kis !! Used to check if it is time to dump the solution.
                    !! The check involves incrementing KIS at the end of the step, and
                    !! dumping the solution if KIS is 0.
                    !!
                    !!  * -1  Set in DIVAcr when it is time to dump solution
                    !!  *  0  When starting
                    !!  *  2  After being dumped.
                    !!
                    !! This is set to 1000 just after a user specified discontinuity, and
                    !! counted up from that point.
    integer  :: kmark !! Identifies the type of output associated with the next
                      !! output point specified by TSPECS.
    integer  :: kord1i !! Helps in defining the state of the integrator.
                       !! Frequently has the same value as KORD(1).  Meaning depends on the
                       !! value of KORD(2), or the value about to be assigned to KORD(2).
                       !!
                       !!  * <  0  Happens when preparing to give output with extrapolation.
                       !!  * =  0  Happens when checking F at points for noise test.
                       !!  * =  1  (KORD(2)=-1)  End of integration has been reached.
                       !!  * =  1  (KORD(2)= 0)  Computing first predicted derivative.
                       !!  * =  1  (KORD(2)= 1)  Output for initial point.
                       !!  * =  2  (KORD(2)=-1)  Giving diagnostic for noise limiting precision.
                       !!  * =  2  (KORD(2)= 0)  Computing corrected derivative.
                       !!  * =  2  (KORD(2)= 1)  Output for TSPECS(3).
                       !!  * =  3  (KORD(2)=-1)  Diagnostic for step size reduction too fast.
                       !!  * =  3  (KORD(2)= 0)  Computing variational derivative.
                       !!  * =  3  (KORD(2)= 1)  Output for TSPECS(4).
                       !!  * =  4  (KORD(2)=-1)  Error, discontinuity.
                       !!  * =  4  (KORD(2)= 1)  Output for certain number of steps.
                       !!  * =  5  (KORD(2)= 0)  Get initial derivatives for stiff equations.
                       !!  * =  5  (KORD(2)= 1)  Extra output from TSPECS.
                       !!  * =  6  (KORD(2)= 1)  End of step output.
                       !!  * =  7  (KORD(2)= 0)  Evaluate G before extrapolated output point.
                       !!  * =  7  (KORD(2)= 1)  Evaluate G before extrapolated output point.
                       !!    (Also used when checking for other G's after
                       !!    finding one.)
                       !!  * =  8  (KORD(2)= 1)  Tell user step size has changed.
                       !!  * =  9  (KORD(2)= 1)  Request for user to save solution.
                       !!  * = 11  (KORD(2)=-1)  Error, step size too small at end of start.
                       !!  * = 12  (KORD(2)=-1)  Error, step size is too small.
                       !!  * = 13  (KORD(2)=-1)  Error, output points specified badly.
                       !!  * = 21  (KORD(2)=-1)  H too small to give reasonable change when added
                       !!    to T.
                       !!  * = 22  (KORD(2)=-1)  Error, bad tolerance.
                       !!  * = 23  (KORD(2)=-1)  Set after message for a fatal error.
                       !!  * = 24  Set on error message in DIVA, along with KORD2I = -4.
                       !!
                       !! Also used as an index into MLOC in DIVAA when an error is being
                       !! processsed, see MLOC below.
    integer  :: kord2i !! Helps in defining the state of the integrator.
                       !! Frequently has the same value as KORD(2).
                       !!
                       !!  * -3  Set in DIVAg, to get a derivative evaluation.
                       !!  * -2  Set in DIVAg, to get another entry to OUTPUT.
                       !!  * -1  Return to calling program, done, interrupt, or got an error.
                       !!  *  1  Calling OUTPUT or returning to user for OUTPUT type action.
                       !!  *  0  Calling DERIVS or returning to user for DERIVS type action.
                       !!  * -4  Error message in DIVA and in DIVAop, along with KORD1I = 24.
                       !!  * -5  Starting
                       !!  * -6  Starting, getting the initial derivative value or derivatives
                       !!    for the noise test.
                       !!  * -7  Done some extrapolation, KEXIT defines the action to take.
                       !!     Set in DIVAg to activate KEXIT action in DIVA.
                       !!  * -8  Set when user has requested adjustment of the difference
                       !!    tables for a discontinutiy.
    integer  :: kpred !! Value assigned to KORD1I when getting a predicted
                      !! derivative.  (1 used now, 5 planned for use with stiff equations.)
    integer  :: kqdcon !! Number of coefficients computed with constant step
                       !! size for stiff equations.
    integer  :: kqicon !! Number of coefficients computed with constant step
                       !! size for nonstiff equations.
    integer  :: kqmaxs !! Maximum integration order for equations that have
                       !! some limit on the error that can be committed.
    integer  :: kqmxds !! Used to save KQMAXD in case step is repeated and the
                       !! solution must be dumped.
    integer  :: kqmxil !! Value of KQMAXI the last time integration coefficients
                       !! were computed.
    integer  :: kqmxip !! = KQMAXI + MAXINT, for computing integration coeffs.
    integer  :: kqmxis !! Used to save KQMAXI in case step is repeated and the
                       !! solution must be dumped.
    integer  :: ksc !! Number of steps that have been taken with a constant
                    !! step size.
    integer  :: ksout !! When KSTEP reaches this value, the output routine is
                      !! called with KORD(1) = 4.  The default value is a very large number.
    integer  :: ksstrt !! Set when ending one derivative per step to KSTEP + 2.
                       !! Checked later in DIVAHC to decide whether to set the step changing
                       !! factors to their nominal values.
    integer  :: kstep !! Number of steps taken since the start of integration.
    integer  :: lex !! Indicates how to get values at next output point:
                    !!
                    !!  * -1  Extrapolate
                    !!  *  0  Interpolate (The usual case.)
                    !!  *  1  Integrate to the output point, integration is not continued.
    integer  :: linc !! Used to indicate state of step size selection.
                     !!
                     !!  * -10 After computed derivatives at base time, after computing other
                     !!    extra derivatives for the noise test.
                     !!  * -9  After computed second extra derivative for noise test.
                     !!  * -8  After computed first extra derivative for noise test.
                     !!  * -7  Dumping the solution and then doing a user initiated restart,
                     !!    or getting ready to compute extra derivatives for the noise
                     !!    test.
                     !!  * -6  Dumping the solution before a restart.
                     !!  * -5  Set on the first step, and also set when dumping the solution
                     !!    after a discontinuity.
                     !!  * -4  Repeat step with no change in the step size.
                     !!  * -3  Set when the error tolerance is set improperly.
                     !!  * -2  User has complete control of selecting the step size.
                     !!  * -1  Step is being repeated.
                     !!  *  0  Step size is not to be increased on this step.
                     !!  * k>0 Step size can be increased by HINCC**k.
    integer  :: lincd !! Value of smallest k for which HINCC**k >= 2.
                      !! (=-2 if user is specifying all step size changes.)
    integer  :: lincq !! Value of smallest k for which HINCC**k >= 4.
    integer  :: lsc !! Indicates if starting or if noise may be present.
                    !!
                    !!  * k<0 -k steps have been taken for which noise appears to be limiting the precision.
                    !!  * 0   Usual case
                    !!  * 1   Doing 1 derivative per step after initial part of start.
                    !!  * 2   Used as flag that it is time to set LSC=0.
                    !!  * 3   Third step, hold the order constant.
                    !!  * 4   Second step, increase orders from 2 to 3.
                    !!  * 5   First step, third time through the first step (if required).
                    !!  * 6   First step, second time through.
                    !!  * 7   First step, first time through.
                    !!  * 8   Set on initialization.
    integer  :: maxkqd !! Largest integration order allowed for stiff equations.
    integer  :: maxkqi !! Largest integ. order allowed for nonstiff equations.
    integer  :: method !! Defines kind of methods being used.
                       !!  * -1  Only stiff equations are being integrated.
                       !!  *  0  Only nonstiff equations are being integrated.
                       !!  *  1  Both kinds of methods are required.
    integer  :: ne !! Number of equations in the first group.  (=NTE if
                   !! option 18 is not used.)
    integer  :: neptol !! Used for temporary storage and to save the value of
                       !! ITOLEP for error messages.
    integer  :: ng !! Used in DIVAg for the number of g's in the current context.
    integer  :: ngstop(2) !! Dimension 2 array equivalenced to IOP6, and IOP7.  To
                          !! get the number of interpolating and extrapolating G-Stops.
    integer  :: ngtot !! NGTOT(1) gives the number of interpolating G-Stops,
                      !! and NGTOT(2) gives the number of extrapolating G-Stops.
    integer  :: noiseq !! max(2, order of equation for which (error estimate)/
                       !! (error requested) is a maximum).
    integer  :: noutko !! If nonzero, gives the index in KORD where information
                       !! on what equations are to be included in the diagnostic output is
                       !! given.   See option 10.
    integer  :: ntolf !! First location in F() where tolerance specifying
                      !! accuracy desired is stored.
    integer  :: ny !! Total order of the system.
    real(wp) :: alpha(kdim) !! Array with I-th entry = (current step size) / XI(I).
                            !! Used in computing integration coefficients.
    real(wp) :: beta(kdim+1) !! Array with I-th entry = product (K=1,I-1) of
                             !! (current (XI(K)) / XI(K) from previous step), BETA(1)=1. Used in
                             !! updating the difference tables.
    real(wp) :: d(maxstf+maxord,maxord) !! Array to be used later to store coefficients for
                                        !! integrating stiff equations.
                                        !! derivatives.  Not used if option 13 is set.
    real(wp) :: dnoise !! Used in determining if noise is limiting the
                       !! precision.  It is usually |highest difference used in correcting|
                       !! of the equation with the largest error estimate.
    real(wp) :: ds(maxstf+maxord, maxord) !! Array to be used later to store coefficients for
                                          !! estimating errors when integrating stiff equations.
    real(wp) :: dvc1(7)
    real(wp) :: dvc2(7) !! Array used for output of variables HC to TOUT in
                        !! common block DIVAMC.
    real(wp) :: eave !! This is a weighted average of past values of EIMAX.
                     !! It is adjusted to account for expected changes due to step changes.
    real(wp) :: eimax !! Estimate of (error estimate / error requested) if the
                      !! step size should be increased.
    real(wp) :: eimin !! An error estimate is small enough to allow a step
                      !! increase if the estimate of ((error with the step size increased) /
                      !! (error requested)) is less than EIMIN.
    real(wp) :: emax !! Largest value computed for (error estimate) / (error
                     !! requested).
    real(wp) :: erep !! If EMAX > EREP, a step is repeated.  Ordinarily
                     !! this has the value .3.  This is set < 0 if the error tolerance is
                     !! specified improperly, and is set to a large value if the user
                     !! requests complete control over the step size.  EREP is also set
                     !! < 0 after a user specified discontinuity.
    real(wp) :: fdat(11) !! Used to store data for error messages.  (Local array in
                         !! DIVAIN.)
    real(wp) :: g(kdim,maxord) !! Integration coefficients used for predicting solution.
                               !! G(I, J) gives the I-th coefficient for integrating a J-th order
                               !! differential equation.  G(1, 1) is equal to the step size.
    real(wp) :: gs(kdim) !! Integration coefficients used in estimating errors.
    real(wp) :: hc !! Ratio of (new step size) / (old step size)
    real(wp) :: hdec !! Default value to use for HC when reducing the step
                     !! size.  (Values closer to 1 may be used some of the time.)
    real(wp) :: hh !! Equivalenced to G(1,1) = current step size in DIVAA,CR,DA,G,HC.
    real(wp) :: hinc !! Default value to use for HC when increasing the step
                     !! size.  (Values closer to 1 may be used some of the time.)
    real(wp) :: hincc !! Actual value used for default value of HC when
                      !! increasing the step size.  Set to HINC after start is considered
                      !! complete.  During the start HINCC is set to 1.125.
    real(wp) :: hmax !! Largest value allowed for abs(step size).  Default
                     !! value is a very large number.
    real(wp) :: hmaxp9 !! .9 * HMAX.
    real(wp) :: hmin !! Smallest value allowed for abs(step size).  Default
                     !! value is 0.
    real(wp) :: rbq(kdim) !! Array containing data for the preliminary noise test.
    real(wp) :: robnd !! Used to influence the selection of integration order.
                      !! The larger ROBND, the harder it is to increase the order and the
                      !! easier it is to decrease it.
    real(wp) :: rvc2(8) !! Array used for output of variables DNOISE to SNOISE in
                        !! common block DIVAMC.  These are variables that don't require a great
                        !! deal of precision.
    real(wp) :: sigma(kdim) !! The k-th entry of this array contains a factor that
                            !! gives the amount the k-th difference is expected to increase if the
                            !! step size in increased.  These numbers get bigger it there is a past
                            !! history of increasing the step size.
    real(wp) :: snoise !! Value used in comparison with RBQ() on equation with
                       !! largest value for (error estimate) / (error requested).
    real(wp) :: tg(2) !! TG(1) gives the last value of TSPECS(1) for which an
                      !! interpolatory G-Stop has been computed.  TG(2) is defined similarly
                      !! for extrapolatory G-Stops.
    real(wp) :: tgstop(2) !! TGSTOP(1) gives the value of TSPECS(1) where the last
                          !! 0 for an interpolatory G-Stop was found.  TGSTOP(2) is defined
                          !! similarly for extrapolatory G-Stops.
    real(wp) :: tmark !! Location of the next output point.
    real(wp) :: tmarka(2) !! Array of length 2 equivalenced to TMARK (and TMARKX).
    real(wp) :: tmarkx !! Location of the next output point to be found using
                       !! integration or extrapolation.  This variable must follow immediately
                       !! after TMARK in the common block.
    real(wp) :: tolg !! Tolerance to pass to dzero when locating G-Stops.
    real(wp) :: tout !! Location of next output point defined by value of
                     !! TSPECS(3).  Such output is given with KORD(1) = 2.
    real(wp) :: v(kdim+maxord) !! Array used in computing integration coefficients.

    common /divamc/ tg,tgstop,tmark,tmarkx,tout,tolg,hc,hdec,hinc,    &
    &   hincc,hmax,hmaxp9,hmin,alpha,beta,d,g,v,ds,gs,sigma,rbq,dnoise,&
    &   eave,eimax,eimin,emax,erep,robnd,snoise,fdat,icf,ics,igflg,    &
    &   igtype,igstop,ilgrep,ings,iop3,iop4,iop5,iop6,iop7,iop8,iop9,  &
    &   iop10,iop11,iop12,iop13,iop14,iop15,iop16,iop17,iop18,iop19,   &
    &   iop20,iop21,iop22,iop21s,itolep,iy,kemax,kis,kmark,kord1i,     &
    &   kord2i,kpred,kqdcon,kqicon,kqmaxs,kqmxds,kqmxil,kqmxip,kqmxis, &
    &   ksc,ksout,ksstrt,kstep,lex,linc,lincd,lincq,lsc,maxkqd,maxkqi, &
    &   method,ne,neptol,ng,ngtot,noiseq,noutko,ntolf,ny,idat

    equivalence (tmarka(1), tmark)
    equivalence (kexit,     iop17)
    equivalence (g(1, 1),   hh)
    equivalence (ngstop(1), iop6)
    equivalence (izflag,    iy)
    equivalence (igflgs,    itolep)
    equivalence (ivc2(1),   icf)
    equivalence (ioptc(3),  iop3)

    end module divamc_module
!*************************************************************************


        SUBROUTINE UMD2P1 (WHO, WHERE,
     $          N, NE, JOB, TRANS, LVALUE, LINDEX, VALUE,
     $          INDEX, KEEP, CNTL, ICNTL, INFO, RINFO,
     $          B, X, LX, W, LW)
        INTEGER WHO, WHERE, N, NE, JOB, LVALUE, LINDEX, INDEX (LINDEX),
     $          KEEP (20), ICNTL (20), INFO (40), LX, LW
        DOUBLE PRECISION
     $          VALUE (LVALUE), B (LX), X (LX), W (LW)
        DOUBLE PRECISION
     $          CNTL (10), RINFO (20)
        LOGICAL TRANS

C=== UMD2P1 ============================================================
C
C  Unsymmetric-pattern MultiFrontal Package (UMFPACK). Version 2.2d
C  Copyright (C) 1997, Timothy A. Davis, University of Florida, USA.
C  ALL RIGHTS RESERVED.
C  Joint work with Iain S. Duff, Rutherford Appleton Laboratory, UK.
C  July 7, 1997. Work supported by the National Science Foundation
C  (DMS-9223088 and DMS-9504974) and the State of Florida; and by CRAY
C  Research Inc. through the allocation of supercomputing resources.

C***********************************************************************
C* NOTICE:  "The UMFPACK Package may be used SOLELY for educational,   *
C* research, and benchmarking purposes by non-profit organizations and *
C* the U.S. government.  Commercial and other organizations may make   *
C* use of UMFPACK SOLELY for benchmarking purposes only.  UMFPACK may  *
C* be modified by or on behalf of the User for such use but at no time *
C* shall UMFPACK or any such modified version of UMFPACK become the    *
C* property of the User.  UMFPACK is provided without warranty of any  *
C* kind, either expressed or implied.  Neither the Authors nor their   *
C* employers shall be liable for any direct or consequential loss or   *
C* damage whatsoever arising out of the use or misuse of UMFPACK by    *
C* the User.  UMFPACK must not be sold.  You may make copies of        *
C* UMFPACK, but this NOTICE and the Copyright notice must appear in    *
C* all copies.  Any other use of UMFPACK requires written permission.  *
C* Your use of UMFPACK is an implicit agreement to these conditions."  *
C*                                                                     *
C* The MA38 Package in Release 12 of the Harwell Subroutine Library    *
C* (HSL) has equivalent functionality (and identical calling interface)*
C* as UMFPACK (the HSL has single and double precision versions only,  *
C* however).  It is available for commercial use.   Technical reports, *
C* information on HSL, and matrices are available via the World Wide   *
C* Web at http://www.cis.rl.ac.uk/struct/ARCD/NUM.html, or by          *
C* anonymous ftp at seamus.cc.rl.ac.uk/pub.  Also contact Dr. Scott    *
C* Roberts, Harwell Subroutine Library, B 552, AEA Technology,         *
C* Harwell, Didcot, Oxon OX11 0RA, England.                            *
C* telephone (44) 1235 434988, fax (44) 1235 434136                    *
C* email Scott.Roberts@aeat.co.uk, who will provide details of price   *
C* and conditions of use.                                              *
C***********************************************************************

C=======================================================================
C  NOT USER-CALLABLE.

C=======================================================================
C  DESCRIPTION:
C=======================================================================
C
C  print input/output arguments for UMD2FA, UMD2RF, and UMD2SO

C=======================================================================
C  INSTALLATION NOTE:
C=======================================================================
C
C  This routine can be deleted on installation (replaced with a dummy
C  routine that just returns without printing) in order to completely
C  disable the printing of all input/output parameters.  To completely
C  disable all I/O, you can also replace the UMD2P2 routine with a
C  dummy subroutine.  If you make this modification, please do
C  not delete any original code - just comment it out instead.  Add a
C  comment and date to your modifications.

C=======================================================================
C  INPUT:
C=======================================================================
C
C       who:            what routine called UMD2P1:
C                       1: UMD2FA, 2: UMD2RF, 3: UMD2SO
C       where:          called from where:
C                       1: entry of routine, else exit of routine
C       Icntl (3):      if < 3 then print nothing, if 3 then print
C                       terse output, if 4 print info and matrix
C                       values.  If 5, print everything.
C       Icntl (2):      I/O unit on which to print.  No printing
C                       occurs if < 0.
C
C       Parameters to print, see UMD2FA, UMD2RF, or UMD2SO for
C       descriptions:
C
C           n, ne, job, trans, lvalue, lindex, Value, Index, Keep,
C           Icntl, Info, Rinfo, B, X, lx, W, lw

C=======================================================================
C  OUTPUT:
C=======================================================================
C
C       on Icntl (2) I/O unit only

C=======================================================================
C  SUBROUTINES AND FUNCTIONS CALLED / CALLED BY:
C=======================================================================
C
C       called by subroutines:  UMD2FA, UMD2RF, UMD2SO
C       functions called:       MIN
        INTRINSIC MIN

C=======================================================================
C  LOCAL SCALARS:
C=======================================================================

        LOGICAL TRANSA, TRANSC, PRLU, BADLU, SGLTON, PRESRV, SYMBOL
        INTEGER IO, PRL, PRN, K, LUI1, LUI2, LUX1, LUX2, ROW, COL,
     $          FACNE, FACN, NZ, FACJOB, NBLKS, NZOFF, FACTRA, CPERMP,
     $          RPERMP, APP, AXP, AIP, OFFIP, OFFXP, LUBLPP, OFFPP,
     $          BLKPP, P1, P2, P, BLK, K1, K2, KN, LUIIP, LUXXP, NPIV,
     $          NLU, E, LUK, LUPP, LUIP, LUXP, LUDEGR, LUDEGC, LUNSON,
     $          LUSONP, LUCP, LURP, I, J, NZCOL, NZROW, UXP, SON,
     $          PRMAX, LUDIMR, LUDIMC, MAXDR, MAXDC, LUIR1, IP1, IP2,
     $          XP1
        DOUBLE PRECISION
     $          ONE
        PARAMETER (PRMAX = 10)

C  Printing control:
C  -----------------
C  io:      I/O unit for diagnostic messages
C  prl:     printing level
C  prn:     number of entries printed so far
C  prmax:   maximum number of entries to print if prl = 3
C  prlu:    true if printing LU factors
C
C  Location and status of LU factors:
C  ----------------------------------
C  transc:  TRANSC argument in UMD2SO
C  transa:  TRANSA argument in UMD2FA or UMD2RF when matrix factorized
C  badlu:   true if LU factors uncomputed or corrupted
C  presrv:  true if original matrix was preserved when factorized
C  symbol:  true if only symbolic part of LU factors needed on input
C  lui1:    integer part of LU factors start in Index (lui1...)
C  luir1:   Index (luir1 ... lui2) is needed for a call to UMD2RF
C  lui2:    integer part of LU factors end in Index (..lui2)
C  lux1:    real part of LU factors start in Value (lux1...)
C  lux2:    real part of LU factors end in Value (...lux1)
C  ip1:     pointer into leading part of LU factors in Index
C  ip2:     pointer into trailing part of LU factors in Index
C  xp1:     pointer into leading part of LU factors in Value
C
C  Arrays and scalars allocated in LU factors (in order):
C  ------------------------------------------------------
C  app:     Ap (1..n+1) array located in Index (app...app+n)
C  axp:     Ax (1..nz) array located in Value (axp...axp+nz-1)
C  aip:     Ai (1..nz) array located in Index (aip...aip+nz-1)
C  offip:   Offi (1..nzoff) array loc. in Index (offip...offip+nzoff-1)
C  offxp:   Offx (1..nzoff) array loc. in Value (offxp...offxp+nzoff-1)
C  ...      LU factors of each diagonal block located here
C  lublpp:  LUblkp (1..nblks) array in Index (lublpp..lublpp+nblks-1)
C  blkpp:   Blkp (1..nblks+1) array loc. in Index (blkpp...blkpp+nblks)
C  offpp:   Offp (1..n+1) array located in Index (offpp...offpp+n)
C  cpermp:  Cperm (1..n) array located in Index (cpermp...cpermp+n-1)
C  rpermp:  Rperm (1..n) array located in Index (rpermp...rpermp+n-1)
C  ...      seven scalars in Index (lui2-6...lui2):
C  factra:  0/1 if TRANSA argument was false/true in UMD2FA or UMD2RF
C  nzoff:   number of entries in off-diagonal part
C  nblks:   number of diagonal blocks
C  facjob:  JOB argument in UMD2FA or UMD2RF when matrix factorized
C  nz:      entries in A
C  facn:    N argument in UMD2FA or UMD2RF when matrix factorized
C  facne:   NE argument in UMD2FA or UMD2RF when matrix factorized
C
C  A single diagonal block and its LU factors:
C  -------------------------------------------
C  blk:     current diagonal block
C  k1,k2:   current diagonal is A (k1..k2, k1..k2)
C  kn:      order of current diagonal block (= k2-k1+1)
C  sglton:  true if current diagonal block is 1-by-1 (a singleton)
C  luiip:   LU factors of a diagonal block start in Index (luiip...)
C  luxxp:   LU factors of a diagonal block start in Value (luxxp...)
C  npiv:    number of pivots in a diagonal block (0 <= npiv <= kn)
C  nlu:     number of elements in a diagonal block
C  lupp:    LUp (1..nlu) array located in Index (lupp...lupp+nlu-1)
C
C  An element in the LU factors of a single diagonal block:
C  --------------------------------------------------------
C  e:       element
C  luk:     number of pivots in element e
C  luip:    integer part of element is in Index (luip...)
C  luxp:    real part of element e is in Value (luxp...)
C  ludegr:  row degree (number of columns) of U2 block in element e
C  ludegc:  column degree (number of rows) of L2 block in element e
C  lunson:  number of sons of element e in the assembly DAG
C  lusonp:  list of sons of element e in Index(lusonp...lusonp+lunson-1)
C  lucp:    column pattern (row indices) of L2 block in Index (lucp..)
C  lurp:    row pattern (column indices) of U2 block in Index (lurp..)
C  nzcol:   entries in a column of L, including unit diagonal
C  nzrow:   entries in a row of U, including non-unit diagonal
C  uxp:     a row of the U2 block located in Value (uxp...)
C  son:     a son of the element e
C  ludimr:  row dimension (number of columns) in frontal matrix
C  ludimc:  column dimension (number of rows) in frontal matrix
C  maxdr:   largest ludimr for this block
C  maxdc:   largest ludimc for this block
C
C  Other:
C  ------
C  row:     row index
C  col:     column index
C  k:       kth pivot, and general loop index
C  i, j:    loop indices
C  p:       pointer
C  p1:      column of A starts Ai/Ax (p1...), or row Offi/x (p1...)
C  p2:      column of A ends in Ai/Ax (...p2), or row Offi/x (...p2)

C=======================================================================
C  EXECUTABLE STATEMENTS:
C       if (printing disabled on installation) return
C=======================================================================

C-----------------------------------------------------------------------
C  get printing control parameters
C-----------------------------------------------------------------------

        ONE = 1
        IO = ICNTL (2)
        PRL = ICNTL (3)
        IF (PRL .LT. 3 .OR. IO .LT. 0) THEN
C          printing has not been requested
           RETURN
        ENDIF

C-----------------------------------------------------------------------
C  who is this, and where.  Determine if LU factors are to be printed
C-----------------------------------------------------------------------

        IF (WHO .EQ. 1) THEN
           IF (WHERE .EQ. 1) THEN
              WRITE (IO, 6) 'UMD2FA input:'
              PRLU = .FALSE.
           ELSE
              WRITE (IO, 6) 'UMD2FA output:'
              PRLU = .TRUE.
           ENDIF
        ELSE IF (WHO .EQ. 2) THEN
           IF (WHERE .EQ. 1) THEN
              WRITE (IO, 6) 'UMD2RF input:'
              PRLU = .TRUE.
           ELSE
              WRITE (IO, 6) 'UMD2RF output:'
              PRLU = .TRUE.
           ENDIF
        ELSE IF (WHO .EQ. 3) THEN
           IF (WHERE .EQ. 1) THEN
              WRITE (IO, 6) 'UMD2SO input:'
              PRLU = .TRUE.
           ELSE
              WRITE (IO, 6) 'UMD2SO output:'
              PRLU = .FALSE.
           ENDIF
        ENDIF

C-----------------------------------------------------------------------
C  print scalar input arguments: n, ne, job, trans, lvalue, lindex
C-----------------------------------------------------------------------

        IF (WHERE .EQ. 1) THEN
           WRITE (IO, 1)  'Scalar arguments:'
           WRITE (IO, 1)  '   N:         ', N, ' : order of matrix A'
           IF (WHO .EQ. 3) THEN
C             UMD2SO:
              LUI2 = KEEP (5)

C             was A or A^T factorized?
              TRANSA = .FALSE.
              IF (LUI2-6 .GE. 1 .AND. LUI2-6 .LE. LINDEX) THEN
                 TRANSA = INDEX (LUI2-6) .NE. 0
              ENDIF
              TRANSC = TRANS
              IF (.NOT. TRANSC) THEN
                 IF (JOB .EQ. 1) THEN
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve P''Lx=b'
                 ELSE IF (JOB .EQ. 2) THEN
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve UQ''x=b'
                 ELSE IF (.NOT. TRANSA) THEN
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve Ax=b (PAQ=LU was factorized)'
                 ELSE
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve A''x=b (PA''Q=LU was factorized)'
                 ENDIF
              ELSE
                 IF (JOB .EQ. 1) THEN
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve L''Px=b'
                 ELSE IF (JOB .EQ. 2) THEN
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve QU''x=b'
                 ELSE IF (.NOT. TRANSA) THEN
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve A''x=b (PAQ=LU was factorized)'
                 ELSE
                    WRITE (IO, 1) '   JOB:       ', JOB,
     $              ' : solve Ax=b (PA''Q=LU was factorized)'
                 ENDIF
              ENDIF
              IF (TRANSC) THEN
                 WRITE (IO, 1)
     $           '   TRANSC:          .true. : see JOB above '
              ELSE
                 WRITE (IO, 1)
     $           '   TRANSC:         .false. : see JOB above '
              ENDIF

           ELSE
C             UMD2FA or UMD2RF:
              WRITE (IO, 1) '   NE:        ', NE,
     $        ' : entries in matrix A'
              IF (JOB .EQ. 1) THEN
                 WRITE (IO, 1) '   JOB:       ', JOB,
     $           ' : matrix A preserved'
              ELSE
                 WRITE (IO, 1) '   JOB:       ', JOB,
     $           ' : matrix A not preserved'
              ENDIF

              TRANSA = TRANS
              IF (TRANSA) THEN
                 WRITE (IO, 1)
     $           '   TRANSA:          .true. : factorize A transpose'
              ELSE
                 WRITE (IO, 1)
     $           '   TRANSA:         .false. : factorize A'
              ENDIF

           ENDIF
           WRITE (IO, 1) '   LVALUE:    ',LVALUE,
     $     ' : size of VALUE array'
           WRITE (IO, 1) '   LINDEX:    ',LINDEX,
     $     ' : size of INDEX array'
        ENDIF

C-----------------------------------------------------------------------
C  print control parameters:  Icntl, Cntl, and Keep (6..8)
C-----------------------------------------------------------------------

        IF (WHERE .EQ. 1) THEN
           WRITE (IO, 1)
     $     'Control parameters, normally initialized by UMD21I:'
           WRITE (IO, 1) '   ICNTL (1): ', ICNTL (1),
     $     ' : I/O unit for error and warning messages'
           WRITE (IO, 1) '   ICNTL (2): ', IO,
     $     ' : I/O unit for diagnostics'
           WRITE (IO, 1) '   ICNTL (3): ', PRL,
     $     ' : printing control'
           IF (WHO .EQ. 1) THEN
              IF (ICNTL (4) .EQ. 1) THEN
                 WRITE (IO, 1) '   ICNTL (4): ', ICNTL (4),
     $           ' : use block triangular form (BTF)'
              ELSE
                 WRITE (IO, 1) '   ICNTL (4): ', ICNTL (4),
     $           ' : do not permute to block triangular form (BTF)'
              ENDIF
              WRITE (IO, 1) '   ICNTL (5): ', ICNTL (5),
     $        ' : columns examined during pivot search'
              IF (ICNTL (6) .NE. 0) THEN
                 WRITE (IO, 1) '   ICNTL (6): ', ICNTL (6),
     $           ' : preserve symmetry'
              ELSE
                 WRITE (IO, 1) '   ICNTL (6): ', ICNTL (6),
     $           ' : do not preserve symmetry'
              ENDIF
           ENDIF
           IF (WHO .NE. 3) THEN
              WRITE (IO, 1) '   ICNTL (7): ', ICNTL (7),
     $        ' : block size for dense matrix multiply'
           ELSE
              WRITE (IO, 1) '   ICNTL (8): ', ICNTL (8),
     $        ' : maximum number of iterative refinement steps'
           ENDIF
           IF (WHO .EQ. 1) THEN
              WRITE (IO, 3) '   CNTL (1):   ',CNTL (1),
     $        ' : relative pivot tolerance'
              WRITE (IO, 3) '   CNTL (2):   ',CNTL (2),
     $        ' : frontal matrix growth factor'
              WRITE (IO, 1) '   KEEP (6):  ',KEEP(6),
     $        ' : largest positive integer'
              WRITE (IO, 1) '   KEEP (7):  ',KEEP(7),
     $        ' : dense row/col control, d1'
              WRITE (IO, 1) '   KEEP (8):  ',KEEP(8),
     $        ' : dense row/col control, d2'
           ELSE IF (WHO .EQ. 3) THEN
              WRITE (IO, 3) '   CNTL (3):   ',CNTL(3),
     $        ' : machine epsilon'
           ENDIF
        ENDIF

C-----------------------------------------------------------------------
C  print the informational output
C-----------------------------------------------------------------------

        IF (WHERE .NE. 1) THEN
           WRITE (IO, 1) 'Output information:'
           IF (INFO (1) .LT. 0) THEN
              WRITE (IO, 1) '   INFO (1):  ', INFO (1),
     $        ' : error occurred!'
           ELSE IF (INFO (1) .GT. 0) THEN
              WRITE (IO, 1) '   INFO (1):  ', INFO (1),
     $        ' : warning occurred'
           ELSE
              WRITE (IO, 1) '   INFO (1):  ', INFO (1),
     $        ' : no error or warning occurred'
           ENDIF
           IF (WHO .NE. 3) THEN
              WRITE (IO, 1) '   INFO (2):  ', INFO (2),
     $        ' : duplicate entries in A'
              WRITE (IO, 1) '   INFO (3):  ', INFO (3),
     $        ' : invalid entries in A (indices not in 1..N)'
              WRITE (IO, 1) '   INFO (4):  ', INFO (4),
     $        ' : invalid entries in A (not in prior pattern)'
              WRITE (IO, 1) '   INFO (5):  ', INFO (5),
     $        ' : entries in A after summing duplicates'
              WRITE (IO, 1)
     $  '                             and removing invalid entries'
              WRITE (IO, 1) '   INFO (6):  ', INFO (6),
     $        ' : entries in diagonal blocks of A'
              WRITE (IO, 1) '   INFO (7):  ', INFO (7),
     $        ' : entries in off-diagonal blocks of A'
              WRITE (IO, 1) '   INFO (8):  ', INFO (8),
     $        ' : 1-by-1 diagonal blocks in A'
              WRITE (IO, 1) '   INFO (9):  ', INFO (9),
     $        ' : diagonal blocks in A (>1 only if BTF used)'
              WRITE (IO, 1) '   INFO (10): ', INFO (10),
     $        ' : entries below diagonal in L'
              WRITE (IO, 1) '   INFO (11): ', INFO (11),
     $        ' : entries above diagonal in U'
              WRITE (IO, 1) '   INFO (12): ', INFO (12),
     $        ' : entries in L + U + offdiagonal blocks of A'
              WRITE (IO, 1) '   INFO (13): ', INFO (13),
     $        ' : frontal matrices'
              WRITE (IO, 1) '   INFO (14): ', INFO (14),
     $        ' : integer garbage collections'
              WRITE (IO, 1) '   INFO (15): ', INFO (15),
     $        ' : real garbage collections'
              WRITE (IO, 1) '   INFO (16): ', INFO (16),
     $        ' : diagonal pivots chosen'
              WRITE (IO, 1) '   INFO (17): ', INFO (17),
     $        ' : numerically valid pivots found in A'
              WRITE (IO, 1) '   INFO (18): ', INFO (18),
     $        ' : memory used in INDEX'
              WRITE (IO, 1) '   INFO (19): ', INFO (19),
     $        ' : minimum memory needed in INDEX'
              WRITE (IO, 1) '   INFO (20): ', INFO (20),
     $        ' : memory used in VALUE'
              WRITE (IO, 1) '   INFO (21): ', INFO (21),
     $        ' : minimum memory needed in VALUE'
              WRITE (IO, 1) '   INFO (22): ', INFO (22),
     $        ' : memory needed in INDEX for next call to UMD2RF'
              WRITE (IO, 1) '   INFO (23): ', INFO (23),
     $        ' : memory needed in VALUE for next call to UMD2RF'
           ELSE
              WRITE (IO, 1) '   INFO (24): ', INFO (24),
     $        ' : steps of iterative refinement taken'
           ENDIF
           IF (WHO .NE. 3) THEN
              WRITE (IO, 3) '   RINFO (1):  ', RINFO (1),
     $        ' : total BLAS flop count'
              WRITE (IO, 3) '   RINFO (2):  ', RINFO (2),
     $        ' : assembly flop count'
              WRITE (IO, 3) '   RINFO (3):  ', RINFO (3),
     $        ' : pivot search flop count'
              WRITE (IO, 3) '   RINFO (4):  ', RINFO (4),
     $        ' : Level-1 BLAS flop count'
              WRITE (IO, 3) '   RINFO (5):  ', RINFO (5),
     $        ' : Level-2 BLAS flop count'
              WRITE (IO, 3) '   RINFO (6):  ', RINFO (6),
     $        ' : Level-3 BLAS flop count'
           ELSE IF (LW .EQ. 4*N) THEN
              WRITE (IO, 3) '   RINFO (7):  ', RINFO (7),
     $        ' : sparse error estimate omega1'
              WRITE (IO, 3) '   RINFO (8):  ', RINFO (8),
     $        ' : sparse error estimate omega2'
           ENDIF
        ENDIF

C-----------------------------------------------------------------------
C  print input matrix A, in triplet form, for UMD2FA and UMD2RF
C-----------------------------------------------------------------------

        IF (WHERE .EQ. 1 .AND. WHO .NE. 3) THEN

           IF (TRANSA) THEN
              IF (PRL .GE. 5) THEN
                 WRITE (IO, 1) 'The input matrix A transpose:'
                 WRITE (IO, 1) '   VALUE (1 ... ',NE,
     $           ' ): numerical values'
                 WRITE (IO, 1) '   INDEX (1 ... ',NE,
     $           ' ): column indices'
                 WRITE (IO, 1) '   INDEX (',NE+1,' ... ',2*NE,
     $           ' ): row indices'
              ENDIF
              WRITE (IO, 1)
     $        'Input matrix A transpose (entry: row, column, value):'
           ELSE

              IF (PRL .GE. 5) THEN
                 WRITE (IO, 1) 'The input matrix A:'
                 WRITE (IO, 1) '   VALUE (1 ... ',NE,
     $           ' ): numerical values'
                 WRITE (IO, 1) '   INDEX (1 ... ',NE,
     $           ' ): row indices'
                 WRITE (IO, 1) '   INDEX (',NE+1,' ... ',2*NE,
     $           ' ): column indices'
              ENDIF
              WRITE (IO, 1)
     $        'Input matrix A (entry: row, column, value):'

           ENDIF

           PRN = MIN (PRMAX, NE)
           IF (PRL .GE. 4) THEN
              PRN = NE
           ENDIF
           DO 20 K = 1, PRN

              IF (TRANSA) THEN
                 ROW = INDEX (K+NE)
                 COL = INDEX (K)
              ELSE
                 ROW = INDEX (K)
                 COL = INDEX (K+NE)
              ENDIF

              WRITE (IO, 2) K, ROW, COL, VALUE (K)
20         CONTINUE
           IF (PRN .LT. NE) THEN
              WRITE (IO, 7)
           ENDIF
        ENDIF

C-----------------------------------------------------------------------
C  print the LU factors:  UMD2FA output, UMD2RF input/output,
C                         and UMD2SO input
C-----------------------------------------------------------------------

        IF (PRLU .AND. INFO (1) .LT. 0) THEN
           WRITE (IO, 1)
     $     'LU factors not printed because of error flag, INFO (1) ='
     $     , INFO (1)
           PRLU = .FALSE.
        ENDIF

        IF (PRLU) THEN

C          -------------------------------------------------------------
C          description of what must be preserved between calls
C          -------------------------------------------------------------

           LUX1 = KEEP (1)
           LUX2 = KEEP (2)
           LUI1 = KEEP (3)
           LUIR1 = KEEP (4)
           LUI2 = KEEP (5)

           XP1 = LUX1
           IP1 = LUI1
           IP2 = LUI2

C          -------------------------------------------------------------
C          on input to UMD2RF, only the symbol information is used
C          -------------------------------------------------------------

           SYMBOL = WHO .EQ. 2 .AND. WHERE .EQ. 1

           IF (PRL .GE. 5) THEN
              IF (SYMBOL) THEN
                 WRITE (IO, 1)
     $           'KEEP (4...5) gives the location of LU factors'
                 WRITE (IO, 1)
     $           '   which must be preserved for calls to UMD2RF: '
              ELSE
                 WRITE (IO, 1)
     $           'KEEP (1...5) gives the location of LU factors'
                 WRITE (IO, 1)
     $           '   which must be preserved for calls to UMD2SO: '
                 WRITE (IO, 1) '      VALUE ( KEEP (1): ', LUX1,
     $           ' ... KEEP (2): ', LUX2,' )'
                 WRITE (IO, 1) '      INDEX ( KEEP (3): ', LUI1,
     $           ' ... KEEP (5): ', LUI2,' )'
                 WRITE (IO, 1) '   and for calls to UMD2RF: '
              ENDIF
              WRITE (IO, 1) '      INDEX ( KEEP (4): ',LUIR1,
     $        ' ... KEEP (5): ', LUI2,' )'
           ENDIF

           BADLU = LUIR1 .LE. 0 .OR. LUI2-6 .LT. LUIR1 .OR.
     $        LUI2 .GT. LINDEX
           IF (.NOT. SYMBOL) THEN
              BADLU = BADLU .OR. LUX1 .LE. 0 .OR.
     $        LUX1 .GT. LUX2 .OR. LUX2 .GT. LVALUE .OR. LUI1 .LE. 0 .OR.
     $        LUIR1 .LT. LUI1 .OR. LUIR1 .GT. LUI2
           ENDIF

C          -------------------------------------------------------------
C          get the 7 scalars, and location of permutation vectors
C          -------------------------------------------------------------

           IF (BADLU) THEN
C             pointers are bad, so these values cannot be obtained
              FACNE  = 0
              FACN   = 0
              NZ     = 0
              FACJOB = 0
              NBLKS  = 0
              NZOFF  = 0
              FACTRA = 0
           ELSE
              FACNE  = INDEX (LUI2)
              FACN   = INDEX (LUI2-1)
              NZ     = INDEX (LUI2-2)
              FACJOB = INDEX (LUI2-3)
              NBLKS  = INDEX (LUI2-4)
              NZOFF  = INDEX (LUI2-5)
              FACTRA = INDEX (LUI2-6)
           ENDIF

           PRESRV = FACJOB .NE. 0
           TRANSA = FACTRA .NE. 0
           RPERMP = (LUI2-6) - (FACN)
           CPERMP = RPERMP - (FACN)
           IP2 = CPERMP - 1

           IF (PRL .GE. 5) THEN
              IF (SYMBOL) THEN
                 WRITE (IO, 1) 'Layout of LU factors in INDEX:'
              ELSE
                 WRITE (IO, 1)
     $           'Layout of LU factors in VALUE and INDEX:'
              ENDIF
           ENDIF

C          -------------------------------------------------------------
C          get location of preserved input matrix
C          -------------------------------------------------------------

           IF (PRESRV) THEN
C             preserved column-form of original matrix
              APP = IP1
              AIP = APP + (FACN+1)
              IP1 = AIP + (NZ)
              AXP = XP1
              XP1 = XP1 + (NZ)
              IF (PRL .GE. 5 .AND. .NOT. SYMBOL) THEN
                 WRITE (IO, 1)'   preserved copy of original matrix:'
                 WRITE (IO, 1)'      INDEX ( ',APP,' ... ', AIP-1,
     $           ' ): column pointers'
                 WRITE (IO, 1)'      INDEX ( ',AIP,' ... ', IP1-1,
     $           ' ): row indices'
                 WRITE (IO, 1)'      VALUE ( ',AXP,' ... ', XP1-1,
     $           ' ): numerical values'
              ENDIF
           ELSE
              IF (PRL .GE. 5 .AND. .NOT. SYMBOL) THEN
                 WRITE (IO, 1) '   original matrix not preserved.'
              ENDIF
           ENDIF

           BADLU = BADLU .OR.
     $          N .NE. FACN .OR. NZ .LE. 0 .OR. LUIR1 .GT. IP2 .OR.
     $          NBLKS .LE. 0 .OR. NBLKS .GT. N
           IF (.NOT. SYMBOL) THEN
              BADLU = BADLU .OR. XP1 .GT. LUX2 .OR. NZOFF .LT. 0
           ENDIF
           IF (BADLU) THEN
              NBLKS = 0
           ENDIF

           IF (NBLKS .LE. 1) THEN

C             ----------------------------------------------------------
C             single block (or block triangular form not used),
C             or LU factors are corrupted
C             ----------------------------------------------------------

              IF (PRL .GE. 5) THEN
                 WRITE (IO, 1)
     $           '   collection of elements in LU factors:'
                 WRITE (IO, 1) '      INDEX ( ',LUIR1,' ... ', IP2,
     $           ' ): integer data'
                 IF (.NOT. SYMBOL) THEN
                    WRITE (IO, 1) '      VALUE ( ',XP1,' ... ', LUX2,
     $              ' ): numerical values'
                 ENDIF
              ENDIF

           ELSE

C             ----------------------------------------------------------
C             block triangular form with more than one block
C             ----------------------------------------------------------

              OFFIP = IP1
              IP1 = IP1 + (NZOFF)
              OFFXP = XP1
              XP1 = XP1 + (NZOFF)
              OFFPP = CPERMP - (N+1)
              BLKPP = OFFPP - (NBLKS+1)
              LUBLPP = BLKPP - (NBLKS)
              IP2 = LUBLPP - 1
              BADLU = BADLU .OR. LUIR1 .GT. IP2
              IF (.NOT. SYMBOL) THEN
                 BADLU = BADLU .OR. IP1 .GT. IP2 .OR.
     $           XP1 .GT. LUX2 .OR. LUIR1 .NE. IP1
              ENDIF

              IF (PRL .GE. 5) THEN
                 WRITE (IO, 1)
     $           '   matrix permuted to upper block triangular form.'
                 IF (NZOFF .NE. 0 .AND. .NOT. SYMBOL) THEN
                    WRITE (IO, 1)'   entries not in diagonal blocks:'
                    WRITE (IO, 1)'      INDEX ( ',OFFIP,' ... ',
     $              LUIR1-1, ' ): row indices'
                    WRITE (IO, 1)'      VALUE ( ',OFFXP,' ... ',
     $              XP1-1, ' ): numerical values'
                 ENDIF
                 WRITE (IO, 1)
     $  '   collection of elements in LU factors of diagonal blocks:'
                 IF (LUIR1 .LE. LUBLPP-1) THEN
                    WRITE (IO, 1) '      INDEX ( ',LUIR1,' ... ',
     $              IP2, ' ): integer data'
                 ENDIF
                 IF (XP1 .LE. LUX2 .AND. .NOT. SYMBOL) THEN
                    WRITE (IO, 1) '      VALUE ( ',XP1,' ... ', LUX2,
     $              ' ): numerical values'
                 ENDIF
                 WRITE (IO, 1) '   other block triangular data:'
                 WRITE (IO, 1) '      INDEX ( ',LUBLPP,' ... ',
     $           BLKPP-1, ' ): pointers to block factors'
                 WRITE (IO, 1) '      INDEX ( ', BLKPP,' ... ',
     $           OFFPP-1, ' ): index range of blocks'
                 IF (.NOT. SYMBOL) THEN
                    WRITE (IO, 1) '      INDEX ( ', OFFPP,' ... ',
     $              LUI2-7,' ): off-diagonal row pointers'
                 ENDIF
              ENDIF

           ENDIF

C          -------------------------------------------------------------
C          print location of permutation vectors and 7 scalars at tail
C          -------------------------------------------------------------

           IF (PRL .GE. 5) THEN
              WRITE (IO, 1)
     $        '   permutation vectors (start at KEEP(4)-2*N-6):'
              WRITE (IO, 1) '      INDEX ( ',CPERMP,' ... ',RPERMP-1,
     $        ' ): column permutations'
              WRITE (IO, 1) '      INDEX ( ',RPERMP,' ... ',LUI2-7,
     $        ' ): row permutations'
              WRITE (IO, 1) '   other data in INDEX: '
              WRITE (IO, 1) '      INDEX ( ',LUI2-6,' ): ', FACTRA,
     $        ' : TRANSA UMD2FA/UMD2RF argument'
              WRITE (IO, 1) '      INDEX ( ',LUI2-5,' ): ', NZOFF,
     $        ' : entries in off-diagonal part'
              WRITE (IO, 1) '      INDEX ( ',LUI2-4,' ): ', NBLKS,
     $        ' : number of diagonal blocks'
              WRITE (IO, 1) '      INDEX ( ',LUI2-3,' ): ', FACJOB,
     $        ' : JOB UMD2FA/UMD2RF argument'
              WRITE (IO, 1) '      INDEX ( ',LUI2-2,' ): ', NZ,
     $        ' : entries in original matrix'
              WRITE (IO, 1) '      INDEX ( ',LUI2-1,' ): ', FACN,
     $        ' : N UMD2FA/UMD2RF argument'
              WRITE (IO, 1) '      INDEX ( ',LUI2  ,' ): ', FACNE,
     $        ' : NE UMD2FA/UMD2RF argument'
           ENDIF

           IF (.NOT. SYMBOL) THEN
              BADLU = BADLU .OR. IP1 .NE. LUIR1
           ENDIF
           IP1 = LUIR1
           IF (BADLU) THEN
              WRITE (IO, 1) 'LU factors uncomputed or corrupted!'
              PRESRV = .FALSE.
              NBLKS = 0
           ENDIF

C          -------------------------------------------------------------
C          copy of original matrix in column-oriented form
C          -------------------------------------------------------------

           IF (PRESRV .AND. .NOT. SYMBOL) THEN
              WRITE (IO, 8)
              WRITE (IO, 1)
     $        'Preserved copy of original matrix (stored by column),'
              WRITE (IO, 1) 'one entry per line (row index, value):'
              DO 40 COL = 1, N
                 P1 = INDEX (APP-1 + COL)
                 P2 = INDEX (APP-1 + COL+1) - 1
                 WRITE (IO, 1) '   col: ', COL
                 IF (PRL .EQ. 3) THEN
                    P2 = MIN (PRMAX, P2)
                 ENDIF
                 DO 30 P = P1, P2
                    WRITE (IO, 5) INDEX (AIP-1 + P), VALUE (AXP-1 + P)
30               CONTINUE
                 IF (PRL .EQ. 3 .AND. P2 .GE. PRMAX) THEN
C                   exit out of loop if done printing:
                    WRITE (IO, 7)
                    GO TO 50
                 ENDIF
40            CONTINUE
C             loop exit label:
50            CONTINUE
           ENDIF

C          -------------------------------------------------------------
C          entries in off-diagonal blocks, in row-oriented form
C          -------------------------------------------------------------

           IF (NBLKS .GT. 1 .AND. .NOT. SYMBOL) THEN
              WRITE (IO, 8)
              WRITE (IO, 1)
     $        'Entries not in diagonal blocks (stored by row):'
              WRITE (IO, 1) 'one entry per line (column index, value):'
              IF (NZOFF .EQ. 0) THEN
                 WRITE (IO, 1) '   (none)'
              ENDIF
              DO 70 ROW = 1, N
                 P1 = INDEX (OFFPP-1 + ROW)
                 P2 = INDEX (OFFPP-1 + ROW+1) - 1
                 IF (P2 .GE. P1) THEN
                    WRITE (IO, 1) '   row: ', ROW
                    IF (PRL .EQ. 3) THEN
                       P2 = MIN (PRMAX, P2)
                    ENDIF
                    DO 60 P = P1, P2
                       WRITE (IO, 5)
     $                 INDEX (OFFIP-1 + P), VALUE (OFFXP-1 + P)
60                  CONTINUE
                 ENDIF
                 IF (PRL .EQ. 3 .AND. P2 .GE. PRMAX) THEN
C                   exit out of loop if done printing:
                    WRITE (IO, 7)
                    GO TO 80
                 ENDIF
70            CONTINUE
C             loop exit label:
80            CONTINUE
           ENDIF

C          -------------------------------------------------------------
C          LU factors of each diagonal block
C          -------------------------------------------------------------

           WRITE (IO, 8)
           IF (NBLKS .GT. 0) THEN
              IF (SYMBOL) THEN
                 WRITE (IO, 1) 'Nonzero pattern of prior LU factors:'
              ELSE
                 WRITE (IO, 1) 'LU factors:'
              ENDIF
           ENDIF
           PRN = 0
           DO 200 BLK = 1, NBLKS

C             ----------------------------------------------------------
C             print the factors of a single diagonal block
C             ----------------------------------------------------------

              IF (NBLKS .GT. 1) THEN
                 K1 = INDEX (BLKPP-1 + BLK)
                 K2 = INDEX (BLKPP-1 + BLK+1) - 1
                 KN = K2-K1+1
                 SGLTON = KN .EQ. 1
                 IF (SGLTON) THEN
C                   this is a singleton
                    LUXXP = XP1-1 + INDEX (LUBLPP-1 + BLK)
                 ELSE
                    LUIIP = IP1-1 + INDEX (LUBLPP-1 + BLK)
                 ENDIF
                 IF (BLK .GT. 1) THEN
                    WRITE (IO, 9)
                 ENDIF
              ELSE
                 SGLTON = .FALSE.
                 K1 = 1
                 K2 = N
                 KN = N
                 LUIIP = IP1
              ENDIF

              IF (SGLTON) THEN

C                -------------------------------------------------------
C                this is a singleton
C                -------------------------------------------------------

                 IF (PRL .EQ. 3 .AND. PRN .GE. PRMAX) THEN
C                   exit out of loop if done printing:
                    WRITE (IO, 7)
                    GO TO 210
                 ENDIF
                 PRN = PRN + 1
                 IF (SYMBOL) THEN
                    WRITE (IO, 1) 'Block: ', BLK,
     $              ' (singleton) at index : ', K1
                 ELSE
                    WRITE (IO, 4) 'Block: ', BLK,
     $              ' (singleton) at index : ', K1,'       value: ',
     $              VALUE (LUXXP)
                 ENDIF
                 IF (PRL .GE. 5) THEN
                    WRITE (IO, 1) 'located in VALUE ( ', LUXXP,' )'
                 ENDIF

              ELSE

C                -------------------------------------------------------
C                this block is larger than 1-by-1
C                -------------------------------------------------------

                 LUXXP = XP1-1 + INDEX (LUIIP)
                 NLU = INDEX (LUIIP+1)
                 NPIV = INDEX (LUIIP+2)
                 MAXDC = INDEX (LUIIP+3)
                 MAXDR = INDEX (LUIIP+4)
                 LUPP = LUIIP+5
                 IF (NBLKS .GT. 1) THEN
                    WRITE (IO, 1) 'Block: ',BLK,' first index: ',K1,
     $              ' last index: ',K2
                 ENDIF
                 IF (PRL .GE. 5) THEN
                    WRITE (IO, 1) 'elements: ', NLU, ' pivots: ', NPIV
                    WRITE (IO, 1) 'largest contribution block: ',
     $                         MAXDC, ' by ', MAXDR
                    WRITE (IO, 1)'located in INDEX ( ',LUIIP,' ... )'
                    IF (.NOT. SYMBOL) THEN
                       WRITE (IO, 1) 'and in VALUE ( ',LUXXP,' ... )'
                    ENDIF
                 ENDIF
                 LUIIP = LUPP + NLU

C                Note: the indices of the LU factors of the block range
C                from 1 to kn, even though the kn-by-kn block resides in
C                A (k1 ... k2, k1 ... k2).
                 K = 0

                 DO 190 E = 1, NLU

C                   ----------------------------------------------------
C                   print a single element
C                   ----------------------------------------------------

                    LUIP = LUIIP-1 + INDEX (LUPP-1 + E)
                    LUXP = LUXXP-1 + INDEX (LUIP)
                    LUK  = INDEX (LUIP+1)
                    LUDEGR = INDEX (LUIP+2)
                    LUDEGC = INDEX (LUIP+3)
                    LUNSON = INDEX (LUIP+4)
                    LUDIMR = INDEX (LUIP+5)
                    LUDIMC = INDEX (LUIP+6)
                    LUCP = LUIP + 7
                    LURP = LUCP + LUDEGC
                    LUSONP = LURP + LUDEGR
                    IF (PRL .GE. 5) THEN
                       WRITE (IO, 1) '   e: ', E, ' pivots: ', LUK
                       WRITE (IO, 1) '   children in dag: ', LUNSON,
     $                 ' frontal matrix: ', LUDIMR, ' by ', LUDIMC
                       ENDIF

C                   ----------------------------------------------------
C                   print the columns of L
C                   ----------------------------------------------------

                    P = LUXP
                    DO 140 J = 1, LUK
                       COL = K+J
                       NZCOL = LUK-J+1+LUDEGC
                       WRITE (IO, 1) '      L, col: ', COL
                       PRN = PRN + 1
                       ROW = COL
                       IF (SYMBOL) THEN
                          WRITE (IO, 5) ROW
                       ELSE
C                         L is unit diagonal:
                          WRITE (IO, 5) ROW, ONE
                       ENDIF
                       P = P + 1
C                      pivot block
                       DO 120 I = J+1, LUK
                          IF (PRL .EQ. 3 .AND. PRN .GE. PRMAX) THEN
C                            exit out of loop if done printing:
                             WRITE (IO, 7)
                             GO TO 210
                          ENDIF
                          PRN = PRN + 1
                          ROW = K+I
                          IF (SYMBOL) THEN
                             WRITE (IO, 5) ROW
                          ELSE
                             WRITE (IO, 5) ROW, VALUE (P)
                          ENDIF
                          P = P + 1
120                    CONTINUE
C                      L block
                       DO 130 I = 1, LUDEGC
                          IF (PRL .EQ. 3 .AND. PRN .GE. PRMAX) THEN
C                            exit out of loop if done printing:
                             WRITE (IO, 7)
                             GO TO 210
                          ENDIF
                          PRN = PRN + 1
                          ROW = INDEX (LUCP-1+I)
                          IF (SYMBOL) THEN
                             WRITE (IO, 5) ROW
                          ELSE
                             WRITE (IO, 5) ROW, VALUE (P)
                          ENDIF
                          P = P + 1
130                    CONTINUE
                       P = P + J
140                 CONTINUE

C                   ----------------------------------------------------
C                   print the rows of U
C                   ----------------------------------------------------

                    UXP = LUXP + LUK*(LUDEGC+LUK)
                    DO 170 I = 1, LUK
                       ROW = K+I
                       NZROW = LUK-I+1+LUDEGR
                       WRITE (IO, 1) '      U, row: ', ROW
                       P = LUXP + (I-1) + (I-1) * (LUDEGC+LUK)
C                      pivot block
                       DO 150 J = I, LUK
                          IF (PRL .EQ. 3 .AND. PRN .GE. PRMAX) THEN
C                            exit out of loop if done printing:
                             WRITE (IO, 7)
                             GO TO 210
                          ENDIF
                          PRN = PRN + 1
                          COL = K+J
                          IF (SYMBOL) THEN
                             WRITE (IO, 5) COL
                          ELSE
                             WRITE (IO, 5) COL, VALUE (P)
                          ENDIF
                          P = P + (LUDEGC+LUK)
150                    CONTINUE
                       P = UXP
C                      U block
                       DO 160 J = 1, LUDEGR
                          IF (PRL .EQ. 3 .AND. PRN .GE. PRMAX) THEN
C                            exit out of loop if done printing:
                             WRITE (IO, 7)
                             GO TO 210
                          ENDIF
                          PRN = PRN + 1
                          COL = INDEX (LURP-1+J)
                          IF (SYMBOL) THEN
                             WRITE (IO, 5) COL
                          ELSE
                             WRITE (IO, 5) COL, VALUE (P)
                          ENDIF
                          P = P + LUK
160                    CONTINUE
                       UXP = UXP + 1
170                 CONTINUE

C                   ----------------------------------------------------
C                   print the sons of the element in the assembly DAG
C                   ----------------------------------------------------

                    IF (PRL .GE. 5) THEN
                       DO 180 I = 1, LUNSON
                          PRN = PRN + 1
                          SON = INDEX (LUSONP-1+I)
                          IF (SON .LE. KN) THEN
C                            an LUson
                             WRITE (IO, 1) '      LUson: ', SON
                          ELSE IF (SON .LE. 2*KN) THEN
C                            a Uson
                             WRITE (IO, 1) '      Uson:  ', SON-KN
                          ELSE
C                            an Lson
                             WRITE (IO, 1) '      Lson:  ', SON-2*KN
                          ENDIF
180                    CONTINUE
                    ENDIF

C                   ----------------------------------------------------
C                   increment count of pivots within this block
C                   ----------------------------------------------------

                    K = K + LUK
190              CONTINUE
              ENDIF
200        CONTINUE
C          loop exit label:
210        CONTINUE

C          -------------------------------------------------------------
C          row and column permutations
C          -------------------------------------------------------------

           IF (.NOT. BADLU) THEN
              PRN = MIN (PRMAX, N)
              IF (PRL .GE. 4) THEN
C                print all of Cperm and Rperm
                 PRN = N
              ENDIF
              WRITE (IO, 8)
              WRITE (IO, 1) 'Column permutations'
              DO 220 I = 1, PRN
                 WRITE (IO, 5) INDEX (CPERMP+I-1)
220           CONTINUE
              IF (PRN .LT. N) THEN
                 WRITE (IO, 7)
              ENDIF
              WRITE (IO, 8)
              WRITE (IO, 1) 'Row permutations'
              DO 230 I = 1, PRN
                 WRITE (IO, 5) INDEX (RPERMP+I-1)
230           CONTINUE
              IF (PRN .LT. N) THEN
                 WRITE (IO, 7)
              ENDIF
           ENDIF

        ENDIF

C-----------------------------------------------------------------------
C  print B (on input) or W and X (on output) for UMD2SO
C-----------------------------------------------------------------------

        IF (WHO .EQ. 3) THEN
           WRITE (IO, 8)
           PRN = MIN (PRMAX, N)
           IF (PRL .GE. 4) THEN
C             print all of B, or W and X
              PRN = N
           ENDIF
           IF (WHERE .EQ. 1) THEN
              WRITE (IO, 1) 'W (1 ... ',LW,
     $        ' ), work vector: not printed'
              WRITE (IO, 1) 'B (1 ... ',N,' ), right-hand side: '
              DO 240 I = 1, PRN
                 WRITE (IO, 5) I, B (I)
240           CONTINUE
              IF (PRN .LT. N) THEN
                 WRITE (IO, 7)
              ENDIF
           ELSE
              IF (INFO (1) .LT. 0) THEN
                 WRITE (IO, 1) 'W (1 ... ',LW,' ), work vector, and'
                 WRITE (IO, 1) 'X (1 ... ',N, ' ), solution,'
                 WRITE (IO, 1)
     $           '   not printed because of error flag, INFO (1) = ',
     $           INFO (1)
              ELSE
                 IF (LW .EQ. 4*N) THEN
C                   UMD2SO did iterative refinement
                    WRITE (IO, 1) 'W (1 ... ',N,' ), residual: '
                    DO 250 I = 1, PRN
                       WRITE (IO, 5) I, W (I)
250                 CONTINUE
                    IF (PRN .LT. N) THEN
                       WRITE (IO, 7)
                    ENDIF
                    WRITE (IO, 1) 'W (',N+1,' ... ',LW,
     $              ' ), work vector: not printed'
                 ELSE
C                   no iterative refinement
                    WRITE (IO, 1) 'W (1 ... ',LW,
     $              ' ), work vector: not printed'
                 ENDIF
                 WRITE (IO, 1) 'X (1 ... ',N,' ), solution: '
                 DO 260 I = 1, PRN
                    WRITE (IO, 5) I, X (I)
260              CONTINUE
                 IF (PRN .LT. N) THEN
                    WRITE (IO, 7)
                 ENDIF
              ENDIF
           ENDIF
        ENDIF

C-----------------------------------------------------------------------
C  who is this, and where:
C-----------------------------------------------------------------------

        IF (WHO .EQ. 1) THEN
           IF (WHERE .EQ. 1) THEN
              WRITE (IO, 6) 'end of UMD2FA input '
           ELSE
              WRITE (IO, 6) 'end of UMD2FA output'
           ENDIF
        ELSE IF (WHO .EQ. 2) THEN
           IF (WHERE .EQ. 1) THEN
              WRITE (IO, 6) 'end of UMD2RF input '
           ELSE
              WRITE (IO, 6) 'end of UMD2RF output'
           ENDIF
        ELSE IF (WHO .EQ. 3) THEN
           IF (WHERE .EQ. 1) THEN
              WRITE (IO, 6) 'end of UMD2SO input '
           ELSE
              WRITE (IO, 6) 'end of UMD2SO output'
           ENDIF
        ENDIF

        RETURN

C=======================================================================
C  FORMAT STATMENTS
C=======================================================================

1       FORMAT (' ', A, :, I12, :, A, :, I12, :,
     $               A, :, I12, :, A, :, I12, :, A, :, I12)
2       FORMAT (' ', I12, ': ', I12, ' ', I12, ' ',
     $          D11.4)
3       FORMAT (' ', A, D11.4, A)
4       FORMAT (' ', A, I12, A, I12, /, A,
     $          D11.4)
5       FORMAT (' ', I12, :, ': ',
     $          D11.4)
6       FORMAT (' ', 59('='), A)
7       FORMAT ('    ...')
8       FORMAT (' ', 79 ('-'))
9       FORMAT (' ', 79 ('.'))
        END


MODULE m_Ekwritesl
  use m_juDFT
CONTAINS
  SUBROUTINE Ek_write_sl(eig_id,kpts,atoms,vacuum,input,jspin,sym,cell,dos,slab,orbcomp,results)
    !-----------------------------------------------------------------
    !-- now write E(k) for all kpts if on T3E
    !-- now read data from tmp_dos and write of E(k) in  ek_orbcomp
    !-----------------------------------------------------------------
    USE m_types
    IMPLICIT NONE

    TYPE(t_input),INTENT(IN)       :: input
    TYPE(t_vacuum),INTENT(IN)      :: vacuum
    TYPE(t_sym),INTENT(IN)         :: sym
    TYPE(t_cell),INTENT(IN)        :: cell
    TYPE(t_dos),INTENT(IN)         :: dos
    TYPE(t_kpts),INTENT(IN)        :: kpts
    TYPE(t_atoms),INTENT(IN)       :: atoms
    TYPE(t_slab),INTENT(IN)        :: slab
    TYPE(t_orbcomp),INTENT(IN)     :: orbcomp
    TYPE(t_results),INTENT(IN)     :: results
    !	..
    !     .. Scalar Arguments ..
    INTEGER, INTENT (IN) :: eig_id
    INTEGER, INTENT (IN) :: jspin
    !     ..
    !     .. Local Scalars
    INTEGER :: nbands,ikpt,kspin,j,i,n,it ,na,iband,mt,l
    INTEGER :: ivac,m
    REAL    :: wk
    !     ..
    !     .. Local Arrays
    INTEGER  norb(23),iqsl(slab%nsld),iqvacpc(2)
    REAL     qvact(2)
    REAL, ALLOCATABLE :: eig(:)
    CHARACTER (len=2) :: chntype
    CHARACTER (len=99) :: chform
    !     ..
    IF (slab%nsl.GT.slab%nsld)  THEN
       CALL juDFT_error("nsl.GT.nsld",calledby="Ek_write_sl")
    ENDIF
    ALLOCATE(eig(input%neig))
    !  --->     open files for a bandstucture with an orbital composition
    !  --->     in the case of the film geometry
    !
    IF (jspin.EQ.1)  OPEN (130,file='ek_orco_11')
    IF (jspin.EQ.2)  OPEN (130,file='ek_orco_12')
    !
    ! ----->       write bandstructure to ek_orbcomp - file
    !
    WRITE (chntype,'(i2)') slab%nsl
    chform = "('E',i3,'= ',f10.4,4x,'vac ( vacuum%layers ) vac = ',i3,' ('&
         &        ,"//chntype//"(i3,2x),')',i3))"
    WRITE (130,FMT=901)
    WRITE (130,FMT=902)
    WRITE (130,FMT=901)
    WRITE (130,FMT=903) slab%nsl,vacuum%nvac,kpts%nkpt
    WRITE (130,FMT=904) atoms%ntype,(atoms%neq(n),n=1,atoms%ntype)
    WRITE (130,FMT=805)
    DO j=1,slab%nsl
       WRITE (130,FMT=806) j,(slab%nslat(i,j),i=1,atoms%nat)
    ENDDO
    DO kspin = 1,input%jspins
       WRITE (130,FMT=907)  kspin,input%jspins
       !==============================================================
901    FORMAT (5X,'--------------------------------------')
902    FORMAT (5X,'-------- E(k) for a input%film  ------------')
903    FORMAT (5X,' nsl =',i3,'   vacuum%nvac =',i2,'   kpts%nkpt =',i4,/)
904    FORMAT (5X,' atoms%ntype = ',i3,' atoms%neq(n) = ',50i3)
907    FORMAT (/,5X,' kspin = ',i4,' input%jspins = ',i4)
805    FORMAT (5X,'  nsl   nslat(1:nate,nsli)  ')
806    FORMAT (5X,51i4)
       !==============================================================
       DO ikpt=1,kpts%nkpt

          WRITE (130,FMT=8000) (kpts%bk(i,ikpt),i=1,3)
8000      FORMAT (/,3x,'  k =',3f10.5,/)
          !
          DO iband = 1,results%neig(ikpt,kspin)
             qvact = 0.0
             DO ivac = 1,vacuum%nvac
                qvact(ivac) = dos%qvac(iband,ivac,ikpt,kspin)
             ENDDO
             IF (sym%invs .OR. sym%zrfs)    qvact(2) = qvact(1)
             iqvacpc(:) = nint(qvact(:)*100.0)
             DO j = 1,slab%nsl
                iqsl(j) = nint((slab%qintsl(j,iband,ikpt,kspin) + slab%qmtsl(j,iband,ikpt,kspin))*100.0)
             ENDDO
             WRITE(130,FMT=chform) iband,results%eig(iband,ikpt,kspin),iqvacpc(2),(iqsl(l),l=1,slab%nsl),iqvacpc(1)
             WRITE(130,FMT=9)
             WRITE(130,FMT=8)
             WRITE(130,FMT=9)
             DO n = 1,slab%nsl
                mt=0
                DO  it=1,atoms%ntype
                   DO  m=1,atoms%neq(it)
                      mt=mt+1
                      na = slab%nslat(mt,n)
                      IF (na.EQ.1) THEN
                         DO  j=1,23
                            norb(j) = nint ( orbcomp%comp(iband,j,mt,ikpt,kspin) )
                         ENDDO
                         WRITE (130,FMT=5) n,it,m,(norb(l),l=1,23),orbcomp%qmtp(iband,mt,ikpt,kspin)
                      ENDIF
                   ENDDO
                enddo
             ENDDO              ! over ( n = 1,nsl )
             WRITE(130,FMT=9)
          ENDDO           ! over ( iband = 1,results%neig(ikpt,kspin) )
       ENDDO        ! over ( ikpt=1,kpts%nkpt )
    ENDDO	  ! over ( kspin = 1,input%jspins )
    CLOSE (130)
    !
    ! 8040 FORMAT ('E',i3,'= ',f10.4,4x,'vac | layers | vac = ',i3,' | ',50(i3,2x),' | ',i3)
8   FORMAT('|lyr,tp,at| S | Px  Py  Pz | Dxy  Dyz  Dzx  Dx-y Dz2 |',&
         &  ' Fx3  Fy3  Fz3  Fx2y Fy2z Fz2x Fxyz| Fz2x Fz2y Fz3  Fxyz Fx2z',&
         &  ' Fx3  Fy3 |  mt  |')
5   FORMAT('|',i3,',',i2,',',i2,'|',i3,'|',3(i3,1x),'|',&
         &        5(1x,i3,1x),'|',&
         &        7(1x,i3,1x),'|',7(1x,i3,1x),'|',f6.1,'|')
9   FORMAT(133('-'))
    !
    DEALLOCATE ( eig )

  END SUBROUTINE Ek_write_sl
END MODULE m_Ekwritesl