*DECK ASMDRV
      SUBROUTINE ASMDRV(IPSYS,IPTRK,IPMACR,IFTRAK,CDOOR,IPRNTP,NGROUP,
     >                  NBMIX,NREGIO,NANI,NANIST,MATCOD,VOLUME,LEAKSW,
     >                  ITRANC,LDIFF,TITRE,ITPIJ,LNORM,IPHASE,ISTRM,
     >                  KNORM)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Dragon assembly and pij phases.
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): G. Marleau
*
*Parameters: input
* IPSYS   pointer to the pij LCM object.
* IPTRK   pointer to the tracking LCM object.
* IPMACR  pointer to the macrolib LCM object.
* IFTRAK  file unit number for tracks.
* CDOOR   name of the pij calculation door.
* IPRNTP  print option for pij calculations.
* NGROUP  number of groups treated.
* NBMIX   number of mixtures considered.
* NREGIO  number of regions considered .
* NANI    number of Legendre orders for scattering cross sections.
* NANIST  number of Legendre orders for scattering cross sections
*         if streaming leakage is present.
* MATCOD  mixture code in each region.
* VOLUME  volume of each region.
* LEAKSW  leakage switch.
* ITRANC  type of transport correction.
* LDIFF   diffusion coefficient switch.
* TITR    execution title.
* ITPIJ   type of collision probability available:
*         =1 scatt mod pij (wij);
*         =2 stand. pij;
*         =3 scatt mod pij+pijk (wij,wijk);
*         =4 stand. pij+pijk.
* LNORM   switch for removing leakage from collision probabilities and
*         keeping the pis information.
* IPHASE  type of assembly (=1 for ass and 2 for pij).
* ISTRM   type of streaming effect:
*         =1 no streaming effect;
*         =2 isotropic streaming effect;
*         =3 anisotropic streaming effect (only available if iphase=2).
* KNORM   type of pij normalization.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      CHARACTER   CDOOR*12,TITRE*72
      LOGICAL     LEAKSW,LDIFF,LNORM
      TYPE(C_PTR) IPSYS,IPTRK,IPMACR
      INTEGER     IFTRAK,IPRNTP,NGROUP,NBMIX,NREGIO,NANI,NANIST,
     >            MATCOD(NREGIO),ITRANC,ITPIJ,IPHASE,ISTRM,KNORM
      REAL        VOLUME(NREGIO)
*----
*  LOCAL VARIABLES
*----
      PARAMETER  (IUNOUT=6,ILCMUP=1,ILCMDN=2)
      LOGICAL     LTRANC,LTP1
      CHARACTER   HSMG*130,CM*2
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS
      TYPE(C_PTR) JPSYS,KPSYS,JPMACR,KPMACR
      REAL, ALLOCATABLE, DIMENSION(:,:) :: XSSIGT,XSSIG1,XSSCOR,XSDIFF
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSSIGW
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(NPSYS(NGROUP))
      ALLOCATE(XSSIGT(0:NBMIX,NGROUP),XSSIG1(0:NBMIX,NGROUP),
     >         XSSIGW(0:NBMIX,NANIST,NGROUP),XSSCOR(NBMIX,NGROUP),
     >         XSDIFF(0:NBMIX,NGROUP))
*----
*  CHECK MIXTURE INDICES.
*----
      DO 10 I=1,NREGIO
      IF(MATCOD(I).GT.NBMIX) THEN
         WRITE (HSMG,5090) NBMIX
         CALL XABORT(HSMG)
      ENDIF
   10 CONTINUE
*----
*  READ X-SECTIONS AND COMPUTE TRANSPORT CORRECTED X-SECTIONS.
*----
      IF(IPRNTP.GE.1) THEN
        IF(IPHASE.EQ.1) THEN
          WRITE(IUNOUT,6200) CDOOR
        ELSE
          WRITE(IUNOUT,6201) CDOOR
        ENDIF
        IF(ITRANC.NE.0) WRITE(IUNOUT,6101) ITRANC
      ENDIF
      IF(IPRNTP.GE.2) THEN
        WRITE(IUNOUT,6000)
        WRITE(IUNOUT,6001) (IREGIO,VOLUME(IREGIO),MATCOD(IREGIO),
     >                      IREGIO=1,NREGIO)
      ENDIF
      CALL LCMLEN(IPMACR,'GROUP',ILON,ITYLCM)
      IF(ILON.NE.NGROUP) CALL XABORT('ASMDRV: INVALID MACROLIB.')
      JPMACR=LCMGID(IPMACR,'GROUP')
      JPSYS=LCMLID(IPSYS,'GROUP',NGROUP)
      ITRAN2=0
      LTP1=.FALSE.
      DO 60 IGR=1,NGROUP
        KPMACR=LCMGIL(JPMACR,IGR)
        CALL LCMLEN(KPMACR,'NTOT0',ILCMLN,ITYLCM)
        IF(ILCMLN.GT.0) THEN
          CALL LCMGET(KPMACR,'NTOT0',XSSIGT(1,IGR))
          XSSIGT(0,IGR)=0.0
        ELSE
          CALL LCMLIB(KPMACR)
          CALL XABORT('ASMDRV: READ ERROR ON LCM RECORD= TOTAL')
        ENDIF
        CALL LCMLEN(KPMACR,'NTOT1',ILCMLN,ITYLCM)
        IF(ILCMLN.GT.0) THEN
          LTP1=.TRUE.
          CALL LCMGET(KPMACR,'NTOT1',XSSIG1(1,IGR))
          XSSIG1(0,IGR)=0.0
        ENDIF
        DO 30 IL=1,NANIST
        WRITE(CM,'(I2.2)') IL-1
        CALL LCMLEN(KPMACR,'SIGW'//CM,ILCMLN,ITYLCM)
        IF(ILCMLN.GT.0) THEN
          CALL LCMGET(KPMACR,'SIGW'//CM,XSSIGW(1,IL,IGR))
          XSSIGW(0,IL,IGR)=0.0
        ELSE IF((MOD(ITPIJ,2).EQ.1).AND.(IL.EQ.1)) THEN
          CALL LCMLIB(KPMACR)
          CALL XABORT('ASMDRV: READ ERROR ON LCM RECORD= SIGW'//CM)
        ELSE
          CALL XDRSET(XSSIGW(0,IL,IGR),NBMIX+1,0.0)
        ENDIF
*       Set XSSIGW to zero if the PIJ matrices are not to be scattering-
*       reduced.
        IF(MOD(ITPIJ,2).EQ.0) CALL XDRSET(XSSIGW(0,IL,IGR),NBMIX+1,0.0)
   30   CONTINUE
        CALL LCMLEN(KPMACR,'TRANC',ILCMLN,ITYLCM)
        LTRANC=ILCMLN.GT.0
        IF((ITRANC.NE.0).AND.LTRANC) THEN
*         TRANSPORT CORRECTION (INCLUDE THE LEAKAGE CORRECTION).
          ITRAN2=ITRANC
          CALL LCMGET(KPMACR,'TRANC',XSSCOR(1,IGR))
        ELSE IF(LTP1) THEN
*         PERFORM A LEAKAGE CORRECTION.
          ITRAN2=4
          DO 40 IMAT=1,NBMIX
   40     XSSCOR(IMAT,IGR)=XSSIGT(IMAT,IGR)-XSSIG1(IMAT,IGR)
        ELSE
          ITRAN2=0
          CALL XDRSET(XSSCOR(1,IGR),NBMIX,0.0)
        ENDIF
        IF(ITRAN2.NE.0) THEN
*         INCLUDE TRANSPORT CORRECTION.
          DO 50 IMAT=1,NBMIX
            XSSIGT(IMAT,IGR)=XSSIGT(IMAT,IGR)-XSSCOR(IMAT,IGR)
            IF(MOD(ITPIJ,2).NE.0) XSSIGW(IMAT,1,IGR)=XSSIGW(IMAT,1,IGR)-
     >      XSSCOR(IMAT,IGR)
*           Tibere is using transport-corrected XS for the second
*           equation. Scattering reduction must be performed with
*           transport-corrected SIGS1 values.
            IF(ITPIJ.EQ.3) XSSIGW(IMAT,2,IGR)=XSSIGW(IMAT,2,IGR)-
     >      XSSCOR(IMAT,IGR)
   50     CONTINUE
        ENDIF
        IF(IPRNTP.GE.3) THEN
          WRITE(IUNOUT,6002)  IGR
          WRITE(IUNOUT,6003) (IMIX,XSSIGT(IMIX,IGR),XSSIGW(IMIX,1,IGR),
     >    IMIX=1,NBMIX)
        ENDIF
        IF(LDIFF) THEN
*         INCLUDE DIFFUSION COEFFICIENTS.
          CALL LCMGET(KPMACR,'DIFF',XSDIFF(1,IGR))
          XSDIFF(0,IGR)=1.0E10
        ENDIF
   60 CONTINUE
*----
*  COMPUTE THE CP OR RESPONSE MATRIX INFORMATION FOR THE SOLUTION OF
*  THE BALANCE EQUATION.
*----
      IPIJK=1
      IF(ISTRM.EQ.3) IPIJK=4
      DO 70 IGR=1,NGROUP
      NPSYS(IGR)=IGR
      KPSYS=LCMDIL(JPSYS,IGR)
      CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,XSSIGT(0,IGR))
      IF(LTP1) CALL LCMPUT(KPSYS,'DRAGON-T1XSC',NBMIX+1,2,XSSIG1(0,IGR))
      CALL LCMPUT(KPSYS,'DRAGON-S0XSC',(NBMIX+1)*NANI,2,XSSIGW(0,1,IGR))
      IF(LDIFF) CALL LCMPUT(KPSYS,'DRAGON-DIFF',NBMIX+1,2,XSDIFF(0,IGR))
   70 CONTINUE
      IF(IPHASE.EQ.2) THEN
         CALL DOORPV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP,
     >   NREGIO,NBMIX,NANI,MATCOD,VOLUME,KNORM,IPIJK,LEAKSW,LNORM,
     >   TITRE)
      ELSE
         CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP,
     >   NREGIO,NBMIX,NANI,MATCOD,VOLUME,KNORM,LEAKSW,TITRE)
      ENDIF
*----
*  COMPUTE THE P1 CP OR RESPONSE MATRIX INFORMATION FOR THE ECCO
*  ISOTROPIC STREAMING MODEL.
*----
      IF(ISTRM.EQ.2) THEN
         CALL LCMSIX(IPSYS,'STREAMING',ILCMUP)
         JPSYS=LCMLID(IPSYS,'GROUP',NGROUP)
         IF(ITRAN2.NE.0) THEN
*          REMOVE TRANSPORT CORRECTION.
           DO 80 IGR=1,NGROUP
           DO 80 IMAT=1,NBMIX
             XSSIGT(IMAT,IGR)=XSSIGT(IMAT,IGR)+XSSCOR(IMAT,IGR)
             XSSIGW(IMAT,1,IGR)=XSSIGW(IMAT,1,IGR)+XSSCOR(IMAT,IGR)
   80      CONTINUE
         ENDIF
         IF(NANIST.LE.1) CALL XABORT('ASMDRV: MISSING P1 XS INFO.')
         DO 90 IGR=1,NGROUP
         NPSYS(IGR)=IGR
         KPSYS=LCMDIL(JPSYS,IGR)
         CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,XSSIGT(0,IGR))
         CALL LCMPUT(KPSYS,'DRAGON-S0XSC',(NBMIX+1)*(NANIST-1),2,
     >   XSSIGW(0,2,IGR))
         IF(LDIFF) CALL LCMPUT(KPSYS,'DRAGON-DIFF',NBMIX+1,2,
     >   XSDIFF(0,IGR))
   90    CONTINUE
         IPIJK=1
         IF(IPHASE.EQ.2) THEN
            CALL DOORPV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP,
     >      NREGIO,NBMIX,NANIST-1,MATCOD,VOLUME,KNORM,IPIJK,LEAKSW,
     >      LNORM,TITRE)
         ELSE
            CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IPRNTP,NGROUP,
     >      NREGIO,NBMIX,NANIST-1,MATCOD,VOLUME,KNORM,LEAKSW,TITRE)
         ENDIF
         CALL LCMSIX(IPSYS,' ',ILCMDN)
      ENDIF
      IF(LNORM) LEAKSW=.FALSE.
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(XSDIFF,XSSCOR,XSSIGW,XSSIG1,XSSIGT)
      DEALLOCATE(NPSYS)
      RETURN
*----
*  FORMATS
*----
 5090 FORMAT(32HASMDRV: INVALID VALUE OF NBMIX (,I5,2H).)
 6000 FORMAT(//30X,' EDITION REGION/VOLUME/MIXTURE '//
     >3(5X,'REGION',5X,'VOLUME  ',5X,'MIXTURE')/)
 6001 FORMAT(1P,3(5X,I4,4X,E12.5,4X,I4,4X))
 6002 FORMAT(//30X,' G R O U P : ',I5//31X,
     >'TOTAL AND WITHIN-GROUP MACROSCOPIC CROSS SECTIONS PER MIXTURE '/)
 6003 FORMAT(3(1X,'MIXTURE',4X,'NTOT0',11X,'SIGW',3X)/
     >1P,3(1X,I4,3X,E12.5,3X,E12.5))
 6101 FORMAT(//' USE TRANSPORT CORRECTED CROSS-SECTIONS (ITRANC=',I4,
     >' )')
 6200 FORMAT(//' COMPUTATION OF DRAGON RESPONSE MATRICES BY DOOR =',
     >3X,A12)
 6201 FORMAT(//' COMPUTATION OF DRAGON COMPLETE CP BY DOOR =',
     >3X,A12)
      END
