*DECK NXTVOL
      SUBROUTINE NXTVOL(IPTRK ,IPRINT,MAXMSS,ITYPG ,IDIRC ,IGEO  ,
     >                  ILEV  ,NM    ,NREG  ,NSUR  ,NREGN ,NSURN ,
     >                  MAXPIN,NBPIN ,ITPIN ,DRAPIN,IDREG ,IDSUR ,
     >                  DAMESH,INDXSR,NAREG )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Compute regional volumes.
*
*Copyright:
* Copyright (C) 2005 Ecole Polytechnique de Montreal.
*
*Author(s):
* G. Marleau
*
*Update(s):
* 2005/09/29: Validated with DRAGON and documented in
*             Report IGE-260.
*
*Reference:
*  G. Marleau,
*  \textsl{New Geometries Processing in DRAGON: The NXT: Module},
*  Report IGE-260, \'{E}cole Polytechnique de Montr\'{e}al,
*  Montr\'{e}al, 2005.
*
*Parameters: input
* IPTRK   pointer to the TRACKING data structure.
* IPRINT  intermediate printing level for output.
* MAXMSS  maximum number of elements in MESH array after split.
* ITYPG   type of geometry.
* IDIRC   direction of cell (1 for XYZ, 2 for YZX and 3 for ZXY)
*         Note: for CAR3D without pins IDIRC=1
*         for CAR3D with pins IDIRC specified by pins direction
* IGEO    geometry number.
* ILEV    geometry level.
* NM      mesh size in all directions ($X$, $Y$, $Z$ and $R$)
* NREG    maximum number of regions in splitted geometry.
* NSUR    maximum number of surfaces in splitted geometry.
* NREGN   number of regions in splitted geometry after symmetry.
* NSURN   number of surfaces in splitted geometry after symmetry.
* MAXPIN  maximum number of pins.
* NBPIN   number of pins.
* ITPIN   pins identification.
* DRAPIN  pins position.
* IDREG   region identifier after symmetry.
* IDSUR   surface identifier after symmetry.
* DAMESH  final mesh description for geometry.
*
*Parameters: input/output
* NAREG   last region number considered,
*
*Parameters: temporary storage
* INDXSR  local indexing of surfaces/regions.
*
*-----------------------------------------------------------------------
*
      USE              GANLIB
      IMPLICIT         NONE
*----
*  Subroutine arguments
*----
      TYPE(C_PTR)      IPTRK
      INTEGER          IPRINT,MAXMSS,ITYPG,IGEO,ILEV,NM(4),
     >                 NREG,NSUR,NREGN,NSURN
      INTEGER          MAXPIN,NBPIN
      DOUBLE PRECISION DRAPIN(-1:4,MAXPIN)
      INTEGER          IDREG(NREG),IDSUR(NSUR),ITPIN(3,MAXPIN)
      DOUBLE PRECISION DAMESH(-1:MAXMSS,4)
      INTEGER          NAREG
      INTEGER          INDXSR(4,-NSUR:NREG)
*----
*  Local parameters
*----
      INTEGER          IOUT
      CHARACTER        NAMSBR*6
      PARAMETER       (IOUT=6,NAMSBR='NXTVOL')
      DOUBLE PRECISION DCUTOF,DZERO,DONE
      PARAMETER       (DCUTOF=1.0D-8,DZERO=0.0D0,DONE=1.0D0)
*----
*  Local variables
*----
      INTEGER          NDIM,IDIRC,IDIRCX,NBSUR,NBREG
      CHARACTER        NAMREC*12
      INTEGER          IREG,IDV,ISUR,IDS,INV,INS,LSTREG
*----
*  Allocatable arrays
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: INREN
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SURVOL,SVT,POSTRI
*----
*  Data
*----
      CHARACTER        CLEV(2)*1
      SAVE             CLEV
      DATA             CLEV /'C','P'/
*----
*  Scratch storage allocation
*   SURVOL  area/volume of regions.
*   SVT     temporary area/volume of regions.
*   INREN   temporary vector for new region/surfaces identification.
*----
      ALLOCATE(INREN(-NSURN:NREGN))
      ALLOCATE(SURVOL(-NSUR:NREG),SVT(-NSURN:NREGN))
*----
*  Processing starts:
*  print routine openning output header if required
*  and initialize various parameters.
*----
      IF(IPRINT .GE. 100) THEN
        WRITE(IOUT,6000) NAMSBR
        WRITE(IOUT,6010)
        WRITE(IOUT,6014)  (IDREG(IDV),IDV=1,NREG)
        WRITE(IOUT,6012)
        WRITE(IOUT,6014)  (IDSUR(IDS),IDS=1,NSUR)
      ENDIF
      CALL XDDSET(SURVOL(-NSUR),NSUR+NREG+1,DZERO)
      NDIM=3
      IF(ITYPG .EQ.  5 .OR. ITYPG .EQ. 7) THEN
        IF(ITYPG .EQ. 5) NDIM=2
        CALL NXTVCA(IPRINT,NDIM  ,IDIRC ,MAXMSS,NSUR  ,NREG  ,
     >              NM    ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL)
        IF(NBPIN .GT. 0) THEN
*----
*  Remove pin contributions
*----
          CALL NXTPCA(IPRINT,NDIM  ,IDIRC ,MAXMSS,NSUR  ,NREG  ,
     >                NM    ,DAMESH,NBPIN ,ITPIN ,DRAPIN,
     >                NBSUR ,NBREG ,INDXSR,SURVOL)
        ENDIF
      ELSE IF(ITYPG .EQ.  3 .OR. ITYPG .EQ.  6) THEN
        IF(ITYPG .EQ. 3) NDIM=2
        IDIRCX=-IDIRC
        DAMESH(0,1)=-DAMESH(-1,1)-DAMESH(NM(4),4)
        DAMESH(NM(1),1)=-DAMESH(-1,1)+DAMESH(NM(4),4)
        DAMESH(0,2)=-DAMESH(-1,2)-DAMESH(NM(4),4)
        DAMESH(NM(2),2)=-DAMESH(-1,2)+DAMESH(NM(4),4)
        CALL NXTVCC(IPRINT,NDIM  ,IDIRCX,MAXMSS,NSUR  ,NREG ,
     >              NM    ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL)
        IF(NBPIN .GT. 0) THEN
*----
*  Remove pin contributions
*----
          CALL NXTPCC(IPRINT,NDIM  ,IDIRCX,MAXMSS,NSUR  ,NREG  ,
     >                NM    ,DAMESH,NBPIN ,ITPIN ,DRAPIN,
     >                NBSUR ,NBREG ,INDXSR,SURVOL)
        ENDIF
      ELSE IF(ITYPG .EQ. 10 ) THEN
        NDIM=3
        IDIRCX=-IDIRC
        DAMESH(0,2)=-DAMESH(-1,2)-DAMESH(NM(4),4)
        DAMESH(NM(2),2)=-DAMESH(-1,2)+DAMESH(NM(4),4)
        DAMESH(0,3)=-DAMESH(-1,3)-DAMESH(NM(4),4)
        DAMESH(NM(3),3)=-DAMESH(-1,3)+DAMESH(NM(4),4)
        CALL NXTVCC(IPRINT,NDIM  ,IDIRCX,MAXMSS,NSUR  ,NREG  ,
     >              NM    ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL)
        IF(NBPIN .GT. 0) THEN
*----
*  Remove pin contributions
*----
          CALL NXTPCC(IPRINT,NDIM  ,IDIRCX,MAXMSS,NSUR  ,NREG  ,
     >                NM    ,DAMESH,NBPIN ,ITPIN ,DRAPIN,
     >                NBSUR ,NBREG ,INDXSR,SURVOL)
        ENDIF
      ELSE IF(ITYPG .EQ. 11 ) THEN
        NDIM=3
        IDIRCX=-IDIRC
        DAMESH(0,3)=-DAMESH(-1,3)-DAMESH(NM(4),4)
        DAMESH(NM(3),3)=-DAMESH(-1,3)+DAMESH(NM(4),4)
        DAMESH(0,1)=-DAMESH(-1,1)-DAMESH(NM(4),4)
        DAMESH(NM(1),1)=-DAMESH(-1,1)+DAMESH(NM(4),4)
        CALL NXTVCC(IPRINT,NDIM  ,IDIRCX,MAXMSS,NSUR  ,NREG  ,
     >              NM    ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL)
        IF(NBPIN .GT. 0) THEN
*----
*  Remove pin contributions
*----
          CALL NXTPCC(IPRINT,NDIM  ,IDIRCX,MAXMSS,NSUR  ,NREG  ,
     >                NM    ,DAMESH,NBPIN ,ITPIN ,DRAPIN,
     >                NBSUR ,NBREG ,INDXSR,SURVOL)
        ENDIF
      ELSE IF(ITYPG .EQ. 12 .OR. ITYPG .EQ. 13 ) THEN
        IF(ITYPG .EQ. 12) NDIM=2
        CALL NXTVHT(IPRINT,MAXMSS,NSUR  ,NREG  ,
     >              NM    ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL)
         IF(NBPIN .GT. 0) THEN
*----
*  Remove pin contributions
*----
           ALLOCATE(POSTRI(6*MAXMSS*MAXMSS*6))
           CALL NXTPHT(IPRINT,NDIM  ,IDIRC ,MAXMSS,NSUR  ,NREG  ,
     >                 NM    ,DAMESH,NBPIN ,ITPIN ,DRAPIN,
     >                 NBSUR ,NBREG ,INDXSR,SURVOL,POSTRI)
           DEALLOCATE(POSTRI)
         ENDIF
      ELSE IF(ITYPG .EQ. 20 .OR. ITYPG .EQ. 21 .OR.
     >        ITYPG .EQ. 22 .OR. ITYPG .EQ. 23) THEN
        IF(ITYPG .EQ. 20) NDIM=2
        CALL NXTVCC(IPRINT,NDIM  ,IDIRC ,MAXMSS,NSUR  ,NREG  ,
     >              NM    ,DAMESH,NBSUR ,NBREG ,INDXSR,SURVOL)
        IF(NBPIN .GT. 0) THEN
*----
*  Remove pin contributions
*----
          CALL NXTPCC(IPRINT,NDIM  ,IDIRC ,MAXMSS,NSUR  ,NREG  ,
     >                NM    ,DAMESH,NBPIN ,ITPIN ,DRAPIN,
     >                NBSUR ,NBREG ,INDXSR,SURVOL)
        ENDIF
      ENDIF
*----
*  Save surface and region identification on IPTRK
*----
      CALL XDDSET(SVT,NREGN+NSURN+1,DZERO)
      DO IREG=1,NBREG
        IDV=ABS(IDREG(IREG))
        IF(IDV .GT. NREGN) CALL XABORT(NAMSBR//
     >  ': Number of regions insufficient')
        IF(IDV .NE. 0) THEN
          SVT(IDV)=SVT(IDV)+SURVOL(IREG)
        ENDIF
      ENDDO
      DO ISUR=1,NBSUR
        IDS=ABS(IDSUR(ISUR))
        IF(IDS .GT. NSURN) CALL XABORT(NAMSBR//
     >  ': Number of surfaces insufficient')
        IF(IDS .NE. 0) THEN
          SVT(-IDS)=SVT(-IDS)+SURVOL(-ISUR)
        ENDIF
      ENDDO
*----
*  Remove region/surfaces with 0 volumes
*----
      INV=0
      INREN(0)=0
      DO IDV=1,NREGN
        IF(SVT(IDV) .GT. DCUTOF) THEN
          INV=INV+1
          INREN(IDV)=INV
        ELSE
          INREN(IDV)=0
        ENDIF
      ENDDO
      LSTREG=INV+NAREG
      DO IREG=1,NBREG
        IDV=IDREG(IREG)
        INV=INREN(ABS(IDV))
        IF(INV .NE. 0) INV=INV+NAREG
        IF(IDV .LT. 0) THEN
          IDREG(IREG)=-INV
        ELSE
          IDREG(IREG)=INV
        ENDIF
      ENDDO
      INS=0
      DO IDS=1,NSURN
        IF(SVT(-IDS) .GT. DCUTOF) THEN
          INS=INS+1
          INREN(-IDS)=INS
        ELSE
          INREN(-IDS)=0
        ENDIF
      ENDDO
      DO ISUR=1,NBSUR
        IDS=IDSUR(ISUR)
        INS=INREN(-ABS(IDS))
        IF(INS .NE. 0) INS=INS
        IF(IDS .LT. 0) THEN
          IDSUR(ISUR)=-INS
        ELSE
          IDSUR(ISUR)=INS
        ENDIF
      ENDDO
      NAREG=LSTREG
      WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSE'
      CALL LCMPUT(IPTRK,NAMREC,(NBSUR+NBREG+1)*2,4,SURVOL)
      WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSI'
      CALL LCMPUT(IPTRK,NAMREC,(NBSUR+NBREG+1)*4,1,INDXSR)
      WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'RID'
      CALL LCMPUT(IPTRK,NAMREC,NBREG,1,IDREG)
*----
*  Processing finished:
*  print routine closing output header if required
*  and return
*----
      IF(IPRINT .GE. 100) THEN
        WRITE(IOUT,6011)
        WRITE(IOUT,6014)  (IDREG(IDV),IDV=1,NREG)
        WRITE(IOUT,6013)
        WRITE(IOUT,6014)  (IDSUR(IDS),IDS=1,NBSUR)
        WRITE(IOUT,6001) NAMSBR
      ENDIF
*----
*  Scratch storage deallocation
*----
      DEALLOCATE(SVT,SURVOL)
      DEALLOCATE(INREN)
      RETURN
*----
*  Output formats
*----
 6000 FORMAT('(* Output from --',A6,'-- follows ')
 6001 FORMAT('   Output from --',A6,'-- completed *)')
 6010 FORMAT(' Original regions ID')
 6011 FORMAT(' Final regions ID')
 6012 FORMAT(' Original surfaces ID')
 6013 FORMAT(' Final surfaces ID')
 6014 FORMAT(5I15)
      END
