*DECK LHXUNH SUBROUTINE LHXUNH(IPTRK,IPGEOM,GEONAM,MESH,NCELA,IPLANZ,NCPHY, + ICODE,ZCODE,MVOSU,NREGIO,ISURF,SIDE,ISTATE,NSMIN, + NSMAX,MVOLUM,IHEX,LX,MCODE,IPLANI,VLAT) * *----------------------------------------------------------------------- * *Purpose: * Read and analyse hexagonal geometry. * *Copyright: * Copyright (C) 1991 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): M. Ouisloumen * *Parameters: input * IPTRK pointer to tracking. * IPGEOM pointer to geometry. * GEONAM name of geometry * *Parameters: output * ISURF number of surfaces. * SIDE side of hexagone. * ISTATE state vector. * NSMIN surface minimum index. * NSMAX surface maximum index. * MVOLUM volume maximum index. * IHEX flag for hexagonal geometry (=1 if geometry hexagonal). * LX number of hexagones. * MESH dimension of array REMESH for mesh storage. * NCELA number of cells in assembly after unfolding. * IPLANZ number of Z planes. * NCPHY number of physical cells. * ICODE albedo indices. * ZCODE geometric albedos. * NREGIO number of physical regions. * MVOSU number of volumes ans surfaces. * MCODE =1 if NCODE(5)=5 ,=2 if NCODE(6)=5 ,=0 otherwise. * IPLANI plane identifier. * VLAT lattice indices for surface and volumes. * *----------------------------------------------------------------------- * USE GANLIB PARAMETER(NLCM=25,NSTATE=40,NIXS=9,NIST=2) TYPE(C_PTR) IPTRK,IPGEOM INTEGER LNLCM(NLCM),INVLCM(NIXS),INVSTA(NIST),ISTATE(NSTATE), + NCODE(6),ICODE(6),JCODE(6),ISTOR(8),VLAT(*) REAL ZCODE(6) LOGICAL L1CELL,LGMERG,LGTURN,LSPLIT,LGCELL,LGSYM,LGSIDE,LGPASS LOGICAL LMERG1,LTURN1 CHARACTER LCMNM(NLCM)*12,GEONAM*12,TEXT12*12 *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IGG,IAA,SURL,JNR1,JCEL, + ISECT,LSECT,ISP,ISZ,IBB,ICC,JSS,ISEC1,IXXX,ISS,ISSS,ICELL,IDD, + IAD REAL, ALLOCATABLE, DIMENSION(:) :: ZZZ,ZMZZ,ZZS,AQ,RR TYPE PP INTEGER, POINTER, DIMENSION(:) :: ILOCR END TYPE PP TYPE(PP), ALLOCATABLE, DIMENSION(:) :: JNR2,ISEC2 *---- * DATA STATEMENTS *---- DATA INVLCM,INVSTA /2,3,7,8,12,15,16,17,18,4,13/ DATA ISTOR /12,6,6,4,3,2,2,2/ DATA LCMNM / 'MIX', 'MESHX', 'MESHY', 'MESHZ', 'RADIUS', > 'SIDE', 'SPLITX', 'SPLITY', 'SPLITZ', 'SPLITR', > 'CELL', 'COORD', 'MERGE', 'TURN', 'CLUSTER', > 'NPIN', 'RPIN', 'APIN', 'BIHET', 'POURCE', > 'PROCEL', 'IHEX', 'NCODE', 'ZCODE', 'ICODE'/ * IFCOUR(N)=NINT( (4.+SQRT(1.+4.*FLOAT(N-1)/3.) + +SQRT(1.+4.*FLOAT(N-2)/3.))*.25) IFONC(N,L)= 2+(N-1)*(L+3*(N-2)) * LGSYM=.FALSE. LGMERG=.FALSE. LGTURN=.FALSE. L1CELL=.FALSE. LSPLIT=.FALSE. LGCELL=.FALSE. MCODE=0 NRAY=0 KRAY=0 KSECT=0 IPLANI=0 * * LECTURE DES DIFFERENTS BLOCS SUR LCM * DO 10 I=1,NLCM CALL LCMLEN(IPGEOM,LCMNM(I),LNLCM(I),ITP) 10 CONTINUE * * ELEMINATES OPTIONS NOT CHECKED BY THIS ROUTINE * DO 20 I=1,NIXS IF(LNLCM(INVLCM(I)).NE.0) + CALL XABORT('LHXUNH : '//GEONAM//' WAS NOT UNFOLDED ') 20 CONTINUE * CALL LCMLEN(IPGEOM,'STATE-VECTOR',ILEN,ITP) IF(ITP.NE.1.OR.ILEN.NE.NSTATE) + CALL XABORT('LHXUNH : INVALID STATE VECTOR ') ISTATE(:NSTATE)=0 CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) * * ELEMINATES THE INVALID OPTIONS * DO 30 IST=1, NIST IF(ISTATE(INVSTA(IST)).NE.0) + CALL XABORT('LHXUNH : '//GEONAM//'WAS NOT UNFOLDED') 30 CONTINUE ITYPE=ISTATE(1) LX=ISTATE(3) LZ=ISTATE(5) LZZ=LZ LREG=ISTATE(6) ISTAT9=ISTATE(9) IF(ISTATE(8).EQ.1)LGCELL=.TRUE. IF(ISTATE(10).EQ.1)LGMERG=.TRUE. IF(ISTATE(11).EQ.1)LSPLIT=.TRUE. NDIM=2 NCEL=LX IPLANZ=1 IF(LZ.NE.0) THEN NCEL=LX*LZ NDIM=3 NCELP=LX IPLANZ=LZ ENDIF IF(LX.EQ.1)L1CELL=.TRUE. IF(LGCELL)THEN IF(L1CELL) THEN IF(ITYPE.NE.8.AND.ITYPE.NE.9.AND.ITYPE.NE.24.AND.ITYPE.NE.25) + CALL XABORT('LHXUNH : INVALID TYPE OF GEOMETRY') ELSE IF(ITYPE.NE.8.AND.ITYPE.NE.9) + CALL XABORT('LHXUNH : INVALID TYPE OF GEOMETRY') ENDIF ELSE IF(ITYPE.NE.8.AND.ITYPE.NE.9.AND.ITYPE.NE.24.AND.ITYPE.NE.25) + CALL XABORT('LHXUNH : INVALID TYPE OF GEOMETRY') ENDIF * * RECOVERS BOUDARY CONDITIONS * CALL LCMGET(IPGEOM,'NCODE',NCODE) CALL LCMGET(IPGEOM,'ZCODE',ZCODE) CALL LCMGET(IPGEOM,'ICODE',JCODE) DO 35 I=1,6 IF( JCODE(I).GT.0 )THEN ICODE(I)= JCODE(I) ELSE ICODE(I)= -I ENDIF IF( NCODE(I).EQ.0 )THEN IF( NDIM.EQ.3.AND.(I.EQ.5.OR.I.EQ.6) )THEN CALL XABORT('LHXUNH : A BOUNDARY CONDITION IS MISSING') ENDIF IF( I.EQ.1 )THEN CALL XABORT('LHXUNH : A BOUNDARY CONDITION IS MISSING') ENDIF ICODE(I)= 0 ENDIF 35 CONTINUE * * ELEMINATIONS DES OPTIONS IMCOMPATIBLES * DO 40 I=1,6 IF(NCODE(I).EQ.4.OR.NCODE(I).EQ.7.OR.NCODE(I).EQ.3 .OR. + (NDIM.EQ.2.AND.NCODE(I).EQ.5) .OR. + (NDIM.EQ.2.AND.NCODE(I).EQ.10) ) + CALL XABORT('LHXUNH : INVALID BOUNDARY CONDITION ') IF((NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10) .AND. + (NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10)) CALL XABORT( + 'LHXUNH: UNE SEULE SYMETRIE SELON Z EST VALABLE') IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10 ) THEN ZCODE(5)=ZCODE(6) ICODE(5)=ICODE(6) ELSEIF(NCODE(6) .EQ.5 .OR. NCODE(6) .EQ. 10) THEN ZCODE(6)=ZCODE(5) ICODE(6)=ICODE(5) ENDIF 40 CONTINUE IF(L1CELL) THEN * * CAS D'UNE SEULE CELLULE * IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10 .OR. > NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10 ) CALL XABORT( + 'LHXUNH: THE B.C. SYME FOR ONE CELL IS NOT PERMITTED ') IF(LGCELL) THEN CALL LCMLEN(IPGEOM,'CELL',ILEN,ITP) IF(ILEN.NE.3*ISTAT9.OR.ITP.NE.3) CALL XABORT('LHXUNH: ' + //'MISSING DIMENSION OR TYPE OF CELL ') ALLOCATE(JCEL(3*ISTAT9)) CALL LCMGET(IPGEOM,'CELL',JCEL) WRITE(TEXT12,'(3A4)') (JCEL(ITC),ITC=1,3) CALL LCMLEN(IPGEOM,TEXT12,ILEN,ITP) IF(ILEN.NE.-1.OR.ITP.NE.0) CALL XABORT('LHXUNH: ' + //'INVALID CELL DATA ') CALL LCMSIX(IPGEOM,TEXT12,1) ENDIF CALL LCMLEN(IPGEOM,'SIDE',ISIDE,ITS) IF(ISIDE.EQ.0) CALL XABORT('LHXUNH: SIDE NOT FOUND') IF(ITS.NE.2) CALL XABORT('LHXUNH: SIDE MUST BE REAL') CALL LCMGET(IPGEOM,'SIDE',SIDE) CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITPR) CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITPS) IXX=1 IF(ILENR.GT.0) IXX=ILENR ALLOCATE(ISECT(IXX)) IF(ILENS.GT.0) THEN IF(ILENS.NE.IXX) + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(1)') CALL LCMGET(IPGEOM,'SECTOR',ISECT) ELSE ISECT(:IXX)=1 ENDIF IF(ILENR.GT.0) THEN IF(ITPR.NE.2)CALL XABORT('LHXUNH: RADIUS MUST BE REAL') CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITPS) NRAY=ILENR-1 IF(ILENSP.GT.0) THEN IF(ILENSP.NE.NRAY) + CALL XABORT('LHXUNH: INVALID SPLITR DIMENSION') IF(ITPS.NE.1) CALL XABORT('LHXUNH: SPLITR MUST BE INTEGER') ALLOCATE(ISP(ILENSP)) CALL LCMGET(IPGEOM,'SPLITR',ISP) NRAY=0 DO 36 J=1,ILENSP NRAY=NRAY+ABS(ISP(J)) 36 CONTINUE IF(ILENS.GT.0) THEN ALLOCATE(LSECT(NRAY+1)) MADD=-1 DO 336 J=1,ILENR-1 KSECT=ISECT(J) DO 335 ISPS=1,ISP(J) MADD=MADD+1 LSECT(MADD+1)=KSECT 335 CONTINUE 336 CONTINUE LSECT(NRAY+1)=ISECT(ILENR) DEALLOCATE(ISECT) ALLOCATE(ISECT(NRAY+1)) DO 337 J=1,NRAY+1 ISECT(J)=LSECT(J) 337 CONTINUE DEALLOCATE(LSECT) ENDIF DEALLOCATE(ISP) ENDIF ENDIF * ISURF=6 MVOSU=0 DO 39 K=1,NRAY+1 KSECT=ISECT(K) IF(KSECT.GT.1) THEN MVOSU=MVOSU+6*(KSECT-1) ELSE MVOSU=MVOSU+1 ENDIF 39 CONTINUE DEALLOCATE(ISECT) IF(KSECT.GT.1) ISURF=6*(KSECT-1) MVOLUM=1+NRAY IF(NDIM.EQ.2) THEN NCELA=1 NCPHY=1 MESH=2+NRAY NREGIO=MVOSU ELSEIF(NDIM.EQ.3) THEN CALL LCMLEN(IPGEOM,'MESHZ',LZ,ITZ) IF(LZ.EQ.0) CALL XABORT('LHXUNH: MESHZ NOT FOUND') IF(LZ.NE.2) CALL XABORT('LHXUNH: MISSING DIMENSION OF MESHZ') IF(ITZ.NE.2)CALL XABORT('LHXUNH: MESHZ MUST BE REAL') ALLOCATE(ZZZ(LZ)) CALL LCMGET(IPGEOM,'MESHZ',ZZZ) IF(ZZZ(1).NE.0.) CALL XABORT('LHXUNH: FIRST MESHZ MUST BE 0') CALL LCMLEN(IPGEOM,'SPLITZ',LSZ,ITSZ) IF(LSZ.GT.0) THEN IF(ITSZ.NE.1)CALL XABORT('LHXUNH: SPLITZ MUST BE INTEGER') IF(LSZ.NE.LZ-1)CALL XABORT('LHXUNH: WRONG SPLITZ DIMENSION') ALLOCATE(ISZ(LSZ)) CALL LCMGET(IPGEOM,'SPLITZ',ISZ) CALL LCMSIX(IPTRK,'DATA_DUP',1) CALL LCMPUT(IPTRK,'SPLITZD',LSZ,1,ISZ) CALL LCMSIX(IPTRK,' ',2) MZ=ISZ(1)+1 ALLOCATE(ZMZZ(MZ)) KSP=ISZ(1) PAS=(ZZZ(2)-ZZZ(1))/FLOAT(KSP) ZMZZ(1)=0.0 DO 37 K=1,KSP ZMZZ(K+1)=PAS*FLOAT(K)+ZZZ(1) 37 CONTINUE DEALLOCATE(ISZ) ELSE MZ=LZ ALLOCATE(ZMZZ(MZ)) DO 38 J=1,MZ ZMZZ(J)=ZZZ(J) 38 CONTINUE ENDIF DEALLOCATE(ZZZ) CALL LCMSIX(IPTRK,'DATA_DUP',1) CALL LCMPUT(IPTRK,'MESHZ',MZ,2,ZMZZ) CALL LCMSIX(IPTRK,' ',2) DEALLOCATE(ZMZZ) IPLANZ=MZ-1 ISTATE(5)=IPLANZ NCELA=MZ-1 ISURF=NCELA*ISURF NCPHY=MZ-1 MESH=NCELA*(3+NRAY) NSMIN=MVOSU NSMAX=MVOSU MVOSU=NCELA*MVOSU MVOLUM=NCELA*MVOLUM NREGIO=MVOSU ENDIF NCOUR=1 ISURF=ISURF+NSMIN+NSMAX RETURN ENDIF * * TYPE DE LA SYMETRIE CONSIDEREE * CALL LCMLEN(IPGEOM,'IHEX',ILEN,ITP) IF(ITP.NE.1.OR.ILEN.NE.1)CALL XABORT('LHXUNH: TYPE OF '// + 'SYMETRIE MUST BE INTEGER') CALL LCMGET(IPGEOM,'IHEX',IHEX) IF(IHEX.LT.1.OR.IHEX.GT.9) CALL XABORT('LHXUNH: INVALID TYPE OF ' + //'SYMETRIE') IF(NDIM.EQ.2) THEN * * TRAITEMENT DE LA GEOMETRIE EN 2D * NCELA=NCEL NCELAP=NCEL * * DUPLICATION DE LA SYMETRIE CONSIDEREE * IF(IHEX.LT.9) THEN ALLOCATE(IBB(ISTOR(IHEX)*NCEL)) CALL DEPLIT(IHEX,NCEL,NCELA,IBB) NCELAP=NCELA ELSE ALLOCATE(IBB(NCEL)) DO 137 I=1,NCEL IBB(I)=I 137 CONTINUE ENDIF CALL LCMLEN(IPGEOM,'MIX',ILENX,ITPX) IF(ILENX.NE.NCEL.OR.ITPX.NE.1) THEN CALL XABORT('LHXUNH: MISSING TYPE OR DIMENSION OF MIX') ENDIF NBASE=NCEL+NCELA CALL LCMLEN(IPGEOM,'TURN',ILENT,ITP) IF(ILENT.GT.0) THEN IF(ILENT.NE.NCEL)CALL XABORT('LHXUNH: EXPECTED DIMENSION'// + 'OF TURN') IF(ITP.NE.1)CALL XABORT('LHXUNH: EXPECTED VALUE IN TURN ') LGTURN=.TRUE. ENDIF NBASE=NBASE*2 NBASE=NBASE+NCEL+NCELA ALLOCATE(ICC(NBASE)) NBB=2*NCEL IF(LGCELL) THEN CALL LCMGET(IPGEOM,'MIX',ICC) ICMAX=-1 DO 147 IGX=1,NCEL ICC(IGX)=-ICC(IGX) ICMAX=MAX(ICMAX,ICC(IGX)) 147 CONTINUE IF(ISTAT9.GT.ICMAX)CALL XABORT('LHXUNH: THERE ARE DEFINED' + //' CELLS NOT USED IN THE ASSEMBLY') ELSE CALL LCMGET(IPGEOM,'MIX',ICC) ENDIF IF(LGMERG) THEN CALL LCMLEN(IPGEOM,'MERGE',IAUXN,ITAUX) IF(IAUXN.NE.NCEL.OR.ITAUX.NE.1)CALL XABORT('LHXUNH: DIMEN' + //'SION OR TYPE OF MERGE INVALID') CALL LCMGET(IPGEOM,'MERGE',ICC(NCEL+1)) NCPHY=0 DO 42 I=1,NCEL NCPHY=MAX(NCPHY,ICC(NCEL+I)) 42 CONTINUE ELSE DO 146 I=1,NCEL ICC(NCEL+I)=ICC(I) 146 CONTINUE LGMERG=.TRUE. NCPHY=NCEL ENDIF IF(LGTURN) THEN CALL LCMLEN(IPGEOM,'TURN',IAUXN,ITAUX) IF(IAUXN.NE.NCEL.OR.ITAUX.NE.1)CALL XABORT('LHXUNH: DIMEN' + //'SION OR TYPE OF TURN INVALID') CALL LCMGET(IPGEOM,'TURN',ICC(NBB+1)) ELSE LGTURN=.TRUE. DO 777 ITT=1,NCEL ICC(NBB+ITT)=1 777 CONTINUE ENDIF NBB=NBB+NCEL * * DUPLICATION DE MERGE ET MIX * DO 47 I=1,NCELA ICC(NBB+I)=ICC(IBB(I)) ICC(NBB+NCELA+I)=ICC(IBB(I)+NCEL) 47 CONTINUE * * CAS OU SIDE EST ENTREE UNE SEULE FOIS * LGSIDE=.TRUE. CALL LCMLEN(IPGEOM,'SIDE',ISIDE,IT) IF(ISIDE.GT.0) THEN CALL LCMGET(IPGEOM,'SIDE',SIDE) LGSIDE=.FALSE. ELSEIF(.NOT.LGCELL) THEN CALL XABORT('LHXUNH: SIDE NOT FOUND ') ENDIF * * EVALUATION DE MESH * MESH=2*NCELA NCOUR=1 IF(NCELAP.GT.1)NCOUR=IFCOUR(NCELAP) ICELC0= IFONC(NCOUR,0) ICELC1= IFONC(NCOUR,1)-ICELC0 IF(LGCELL) THEN ALLOCATE(JNR1(ISTAT9),JNR2(ISTAT9),JCEL(3*ISTAT9)) CALL LCMGET(IPGEOM,'CELL',JCEL) NREGIO=0 DO 48 I=1,ISTAT9 IRTC=3*I-2 WRITE(TEXT12,'(3A4)') (JCEL(ITC),ITC=IRTC,IRTC+2) CALL LCMSIX(IPGEOM,TEXT12,1) CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP) CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITP) IF(LGSIDE) THEN CALL LCMLEN(IPGEOM,'SIDE',ISIDE,IT) IF(ISIDE.EQ.0)CALL XABORT('LHXUNH: SIDE NOT FOUND') CALL LCMGET(IPGEOM,'SIDE',SSIDE) IF(I.GT.1) THEN IF(SSIDE.NE.SIDE)CALL XABORT('LHXUNH: INCOMPATIBLE SIDE') ENDIF SIDE=SSIDE ENDIF NRAY=ILENR IF(ILENR.GT.0)NRAY=ILENR-1 IF(ILENSP.GT.0) THEN ALLOCATE(JSS(ILENSP)) CALL LCMGET(IPGEOM,'SPLITR',JSS) NRAY=0 DO 46 J=1,ILENSP NRAY=NRAY+ABS(JSS(J)) 46 CONTINUE DEALLOCATE(JSS) ENDIF JNR1(I)=NRAY ALLOCATE(JNR2(I)%ILOCR(NRAY+1)) CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITPS) IF(ILENS.GT.0) THEN IF(ILENS.NE.NRAY+1) + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(2)') CALL LCMGET(IPGEOM,'SECTOR',JNR2(I)%ILOCR) ELSE JNR2(I)%ILOCR(:NRAY+1)=1 NREGIO=NREGIO+1+NRAY GOTO 430 ENDIF DO 43 K=1,NRAY+1 KSECT=JNR2(I)%ILOCR(K) IF(KSECT.GT.1) THEN NREGIO=NREGIO+6*(KSECT-1) ELSE NREGIO=NREGIO+1 ENDIF 43 CONTINUE 430 CONTINUE CALL LCMSIX(IPGEOM,' ',2) 48 CONTINUE DEALLOCATE(JCEL) NRAY=0 MVOSU=0 MVOLUM=0 ISURF=0 DO 49 I=1,NCELA KRAY=JNR1(ICC(NBB+I)) NRAY=NRAY+KRAY DO 490 JR=1,KRAY+1 KSECT=JNR2(ICC(NBB+I))%ILOCR(JR) IF(KSECT.GT.1) THEN MVOSU=MVOSU+6*(KSECT-1) ELSE MVOSU=MVOSU+1 ENDIF 490 CONTINUE IF(I.GE.ICELC0) THEN IF(KSECT.GT.1) THEN ISURF=ISURF+2*(KSECT-1) IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+KSECT-1 ELSE ISURF=ISURF+2 IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+1 ENDIF ENDIF MVOLUM=MVOLUM+KRAY+1 49 CONTINUE MESH=NRAY+MESH DO 495 I=1,ISTAT9 DEALLOCATE(JNR2(I)%ILOCR) 495 CONTINUE DEALLOCATE(JNR2,JNR1) ELSE CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP) NREGIO=NCPHY MVOSU=NCELA MVOLUM=NCELA ALLOCATE(IXXX(NCEL)) IF(ILENS.GT.0) THEN IF(ILENS.NE.NCEL) + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(3)') CALL LCMGET(IPGEOM,'SECTOR',IXXX) ELSE IXXX(:NCEL)=1 ENDIF ILESS=0 NREGIO=0 DO 50 L=1,ILENS MCEL=ICC(L) IF(MCEL.GT.ILESS) THEN ILESS=MCEL KSECT=IXXX(L) IF(KSECT.GT.1) THEN NREGIO=NREGIO+6*(KSECT-1) ELSE NREGIO=NREGIO+1 ENDIF ENDIF 50 CONTINUE MVOSU=0 ISURF=0 DO 51 I=1,NCELA KSECT=IXXX(ICC(NBB+I)) IF(KSECT.GT.1) THEN MVOSU=MVOSU+6*(KSECT-1) IF(I.GE.ICELC0) THEN ISURF=ISURF+2*(KSECT-1) IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+KSECT-1 ENDIF ELSE MVOSU=MVOSU+1 IF(I.GE.ICELC0) THEN ISURF=ISURF+2 IF(MOD(I-ICELC0,ICELC1).EQ.0) ISURF=ISURF+1 ENDIF ENDIF 51 CONTINUE DEALLOCATE(IXXX) ENDIF * * DUPLICATION DE TURN * MBB=2*NCELA IF(LGTURN) THEN IF (IHEX.LT.9) THEN CALL DUTURN(IHEX,ICC(NBB-NCEL+1),NCEL,ICC(NBB+MBB+1), + NCELA,IBB) ELSE DO 187 I=1,NCELA ICC(NBB+MBB+I)=ICC(NBB-NCEL+I) 187 CONTINUE ENDIF ENDIF * * RESTORAGE DES DONNEES * CALL LCMSIX(IPTRK,'DATA_DUP',1) * *--- CE VECTEUR EST UTILE DANS LA ROUTINE MESHST CALL LCMPUT(IPTRK,'GENER0',NCELA,1,IBB) IF(LGCELL) THEN CALL LCMPUT(IPTRK,'GENERATING',NCELA,1,ICC(NBB+1)) ELSE CALL LCMPUT(IPTRK,'MIX',NCELA,1,ICC(NBB+1)) ENDIF IF(LGMERG) + CALL LCMPUT(IPTRK,'MERGE',NCELA,1,ICC(NCELA+NBB+1)) IF(LGTURN) + CALL LCMPUT(IPTRK,'TURN',NCELA,1,ICC(NBB+MBB+1)) CALL LCMSIX(IPTRK,' ',2) DEALLOCATE(IBB,ICC) * ELSEIF(NDIM.EQ.3) THEN * * TRAITEMENT DU CAS 3D * NCELA=NCEL CALL LCMLEN(IPGEOM,'MIX',ILENX,ITPX) IF(ILENX.NE.NCEL.OR.ITPX.NE.1) CALL XABORT('LHXUNH: MISSING' + //'VECTOR MIX') NBASE=NCEL CALL LCMLEN(IPGEOM,'TURN',ILENT,ITPT) IF(ILENT.GT.0)THEN IF(ILENT.NE.NCEL.OR.ITPT.NE.1) CALL XABORT('LHXUNH: MISSING' + //'VECTOR TURN') LGTURN=.TRUE. ENDIF NBASE=NCEL+NCEL NBASE=NCEL+NBASE ALLOCATE(ICC(NBASE)) CALL LCMGET(IPGEOM,'MIX',ICC) IF(LGCELL) THEN DO 144 IGX=1,NCEL ICC(IGX)=-ICC(IGX) 144 CONTINUE ENDIF NBB=NCEL+NCEL LMERG1=.FALSE. LTURN1=.FALSE. IF(LGMERG) THEN CALL LCMGET(IPGEOM,'MERGE',ICC(NCEL+1)) NCPHY=0 DO 52 I=1,NCEL NCPHY=MAX(NCPHY,ICC(NCEL+I)) 52 CONTINUE LMERG1=.TRUE. ELSE DO 53 I=1,NCEL ICC(I+NCEL)=ICC(I) 53 CONTINUE LGMERG=.TRUE. NCPHY=NCEL ENDIF IF(LGTURN) THEN CALL LCMGET(IPGEOM,'TURN',ICC(NBB+1)) LTURN1=.TRUE. ELSE LGTURN=.TRUE. DO 778 ITT=1,NCEL ICC(NBB+ITT)=1 778 CONTINUE ENDIF NBB=NBB+NCEL * * SPLITING DE LA DIRECTION Z * CALL LCMLEN(IPGEOM,'MESHZ',ILENZ,ITPZ) IF(LGCELL.OR.IPLANZ.GT.1) THEN IF(ILENZ.NE.0)CALL XABORT('LHXUNH: INVALID POSITION OF MESHZ') ENDIF IF(ILENZ.GT.0) THEN IF(ILENZ.NE.LZ+1.OR.ITPZ.NE.2)CALL XABORT('LHXUNH: MISSING' + //'DIMENSION OR VALUE IN MESHZ') ALLOCATE(ZZZ(ILENZ)) CALL LCMGET(IPGEOM,'MESHZ',ZZZ) MZ=ILENZ ENDIF * * EVALUATION DE NREGIO * NREGIO=NCPHY CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP) IF(LGCELL.OR.IPLANZ.GT.1) THEN IF(ILENS.NE.0)CALL XABORT('LHXUNH: INVALID POSITION OF SECTOR') ENDIF IF(ILENS.GT.0) THEN IF(ILENS.NE.NCEL)CALL XABORT('LHXUNH: INVALID DIMENSION OF' + //'SECTOR') IF(ITP.NE.1)CALL XABORT('LHXUNH: SECTOR MUST BE INTEGER') ALLOCATE(ISEC1(ILENS)) ILESS=0 NREGIO=0 CALL LCMGET(IPGEOM,'SECTOR',ISEC1) DO 54 L=1,ILENS MCEL=ICC(L) IF(MCEL.GT.ILESS) THEN ILESS=MCEL KSECT=ISEC1(L) IF(KSECT.GT.1) THEN NREGIO=NREGIO+6*(KSECT-1) ELSE NREGIO=NREGIO+1 ENDIF ENDIF 54 CONTINUE ENDIF * CALL LCMLEN(IPGEOM,'SPLITZ',ILEN,ITP) IF(ILEN.NE.0) THEN IF(ILEN.NE.LZ)CALL XABORT('LHXUNH: INVALID DIMENSION OF' + //'SPLITZ') IF(ILENZ.LT.0)CALL XABORT('LHXUNH: MESHZ MUST BE DEFINED' + //'LIKE SPLITZ') ALLOCATE(ISS(LZ)) CALL LCMGET(IPGEOM,'SPLITZ',ISS) CALL LCMSIX(IPTRK,'DATA_DUP',1) CALL LCMPUT(IPTRK,'SPLITZD',LZ,1,ISS) CALL LCMSIX(IPTRK,' ',2) MZ=0 DO 55 K=1,LZ MZ=MZ+ISS(K) 55 CONTINUE LSPLIT=.TRUE. ELSEIF(LGCELL) THEN CALL LCMLEN(IPGEOM,'CELL',ILEN,ITP) IF(ILEN.NE.3*ISTAT9.OR.ITP.NE.3)CALL XABORT('LHXUNH: ' + //'MISSING DIMENSION OR TYPE OF CELL ') ALLOCATE(ICELL(3*ISTAT9),RR(3*ISTAT9),ISSS(ISTAT9)) CALL LCMGET(IPGEOM,'CELL',ICELL) ALLOCATE(ISEC1(ISTAT9),ISEC2(ISTAT9)) IAUX=0 NREGIO=0 DO 70 I=1,ISTAT9 WRITE(TEXT12(1:4),'(A4)')ICELL(3*I-2) WRITE(TEXT12(5:8),'(A4)')ICELL(3*I-1) WRITE(TEXT12(9:12),'(A4)')ICELL(3*I) CALL LCMSIX(IPGEOM,TEXT12,1) CALL LCMGET(IPGEOM,'MESHZ',RR(IAUX+1)) CALL LCMGET(IPGEOM,'SIDE',RR(2*ISTAT9+I)) IAUX=IAUX+2 CALL LCMLEN(IPGEOM,'SPLITZ',ILEN,ITP) ISSS(I)=1 IF(ILEN.NE.0) THEN IF(ITP.NE.1)CALL XABORT('LHXUNH: INVALID TYPE OF SPLITZ') CALL LCMGET(IPGEOM,'SPLITZ',ISSS(I)) LSPLIT=.TRUE. ENDIF CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP) CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,LT) NRAY=0 NSECT=1 IF(ILENR.GT.0) THEN IF(ITP.NE.2)CALL XABORT('LHXUNH: RADIUS MUST BE REAL ') NRAY=ILENR-1 NSECT=ILENR ENDIF CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP) ALLOCATE(ISECT(NSECT)) IF(ILENS.GT.0) THEN IF(ILENS.NE.NSECT) + CALL XABORT('LHXUNH: INVALID SECTOR DIMENSION(4)') CALL LCMGET(IPGEOM,'SECTOR',ISECT) ELSE ISECT(:NSECT)=1 ENDIF IF(ILENSP.GT.0) THEN IF(LT.NE.1)CALLXABORT('LHXUNH: SPLITR MUST BE INTEGER') ALLOCATE(JSS(ILENSP)) CALL LCMGET(IPGEOM,'SPLITR',JSS) NRAY=0 DO 246 JP=1,ILENSP NRAY=NRAY+ABS(JSS(JP)) 246 CONTINUE ALLOCATE(ISEC2(I)%ILOCR(NRAY+1)) MAD=-1 DO 248 JP=1,ILENS KSECT=ISECT(JP) DO 247 JT=1,JSS(JP) MAD=MAD+1 ISEC2(I)%ILOCR(MAD+1)=KSECT 247 CONTINUE 248 CONTINUE ISEC2(I)%ILOCR(MAD+2)=ISECT(ILENS+1) DEALLOCATE(JSS) ELSE ALLOCATE(ISEC2(I)%ILOCR(NRAY+1)) DO 249 JP=1,NSECT ISEC2(I)%ILOCR(JP)=ISECT(JP) 249 CONTINUE ENDIF DEALLOCATE(ISECT) ISEC1(I)=NRAY DO 255 K=1,NRAY+1 KSECT=ISEC2(I)%ILOCR(K) IF(KSECT.GT.1) THEN NREGIO=NREGIO+6*(KSECT-1) ELSE NREGIO=NREGIO+1 ENDIF 255 CONTINUE CALL LCMSIX(IPGEOM,' ',2) 70 CONTINUE DEALLOCATE(ICELL) * * COMPATIBILITE DES DONNEES DES CELLULES D'UN MEME PLAN * LZZ=LZ IAUX=0 LISP=0 ALLOCATE(ISS(ISTAT9),ZZZ(LZ+1)) MZZ=0 DO 80 I=1,LZ SIDE=RR(2*ISTAT9+ICC(IAUX+1)) LCC=2*(ICC(IAUX+1)-1) Z1=RR(LCC+1) Z2=RR(LCC+2) ZZZ(I)=Z1 ZZZ(I+1)=Z2 IF(LSPLIT) THEN LISP=ISSS(ICC(IAUX+1)) ISS(I)=LISP MZZ=MZZ+LISP LZZ=MZZ ENDIF DO 75 K=2,NCELP IAUX=IAUX+1 IF(SIDE.NE.RR(2*ISTAT9+ICC(IAUX+1))) + CALL XABORT('LHXUNH: INCOMPATIBLE SIDE ') LCC=2*(ICC(IAUX+1)-1) IF((Z1.NE.RR(LCC+1)).OR.(Z2.NE.RR(LCC+2))) + CALL XABORT('LHXUNH: INCOMPATIBLE MESHZ ') IF(LSPLIT) THEN IF(LISP.NE.ISSS(ICC(IAUX+1))) + CALL XABORT('LHXUNH: INCOMPATIBLE SPLITZ') ENDIF 75 CONTINUE IAUX=IAUX+1 80 CONTINUE DEALLOCATE(RR,ISSS) MZ=LZ+1 IF(LSPLIT)MZ=MZZ+1 ENDIF ALLOCATE(ZZS(MZ)) IF(LSPLIT) THEN LAUX=0 Z1=ZZZ(1) ZZS(1)=Z1 DO 83 K=1,LZ MSP=ISS(K) Z2=ZZZ(K+1) PAS=(Z2-Z1)/REAL(MSP) DO 81 L=1,MSP-1 LAUX=LAUX+1 ZZS(LAUX+1)=Z1+PAS*REAL(L) 81 CONTINUE LAUX=LAUX+1 ZZS(LAUX+1)=Z2 Z1=Z2 83 CONTINUE ELSE DO 88 J=1,MZ ZZS(J)=ZZZ(J) 88 CONTINUE ENDIF DEALLOCATE(ZZZ) * * STORAGE DES VALEURS DE Z * CALL LCMSIX(IPTRK,'DATA_DUP',1) LSPLZM=1 LSPLZP=1 IF(LSPLIT) THEN LSPLZM=ISS(1) LSPLZP=ISS(LZ) CALL LCMPUT(IPTRK,'SPLITZD',LZ,1,ISS) ENDIF IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10) THEN IF(NCODE(5) .EQ. 5) THEN MDZ=2*MZ-1-LSPLZM IOFZD=2+LSPLZM ELSE MDZ=2*MZ-1 IOFZD=2 ENDIF ALLOCATE(AQ(MDZ)) IQ=0 DO 583 IW=MZ,IOFZD,-1 AQ(IQ+1)=-ZZS(IW)+ZZS(1)+ZZS(2) IQ=IQ+1 583 CONTINUE DO 584 IW=1,MZ AQ(IQ+1)=ZZS(IW) IQ=IQ+1 584 CONTINUE CALL LCMPUT(IPTRK,'MESHZ',MDZ,2,AQ) DEALLOCATE(AQ) ELSEIF(NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10) THEN IF(NCODE(6) .EQ. 5) THEN MDZ=2*MZ-LSPLZP-1 IOFZD=LSPLZP+1 ELSE MDZ=2*MZ-1 IOFZD=1 ENDIF ALLOCATE(AQ(MDZ)) IQ=0 DO 585 IW=1,MZ AQ(IQ+1)=ZZS(IW) IQ=IQ+1 585 CONTINUE DO 586 IW=MZ-IOFZD,1,-1 AQ(IQ+1)=AQ(IQ)+ZZS(IW+1)-ZZS(IW) IQ=IQ+1 586 CONTINUE CALL LCMPUT(IPTRK,'MESHZ',MDZ,2,AQ) DEALLOCATE(AQ) ELSE CALL LCMPUT(IPTRK,'MESHZ',MZ,2,ZZS) ENDIF CALL LCMSIX(IPTRK,' ',2) DEALLOCATE(ZZS) * IF(IHEX.LT.9) THEN * * DUPLICATION DE LA GEOMETRIE CONSIDEREE * ALLOCATE(IBB(ISTOR(IHEX)*NCEL)) CALL DEPLIT(IHEX,NCELP,NCELAP,IBB) IAUX=NCELP JAUX=NCELAP DO 65 K=2,LZ DO 60 L=1,NCELAP IBB(JAUX+L)=IBB(L)+IAUX 60 CONTINUE IAUX=IAUX+NCELP JAUX=JAUX+NCELAP 65 CONTINUE ELSEIF(IHEX.EQ.9) THEN NCELAP=NCELA/LZ ENDIF IF(LSPLIT)THEN NCELA=NCELAP*LZZ ELSE NCELA=NCELAP*LZ ENDIF * * DUPLICATION DE MERGE ET MIX * NBASE=NCELA+NCELA IF(LGTURN)NBASE=NBASE+NCELA ALLOCATE(IDD(NBASE),IAD(NCELA)) IAUX=-1 JAUX=0 ICELSP=0 MAXSP=0 MINSP=99999 DO 85 I=1,LZ IF(IHEX.LT.9) THEN MAXSP=IBB(JAUX+1) MINSP=MAXSP ENDIF DO 84 J=1,NCELAP IAUX=IAUX+1 IF(IHEX.LT.9) THEN IAD(IAUX+1)=IBB(JAUX+J)+ICELSP MAXSP=MAX(MAXSP,IBB(JAUX+J)) MINSP=MIN(MINSP,IBB(JAUX+J)) IDD(IAUX+1)=ICC(IBB(JAUX+J)) IDD(NCELA+IAUX+1)=ICC(NCEL+IBB(JAUX+J)) ELSE IAD(IAUX+1)=IAUX+1 IDD(IAUX+1)=ICC(JAUX+J) IDD(NCELA+IAUX+1)=ICC(NCEL+JAUX+J) ENDIF 84 CONTINUE IF(LSPLIT) THEN LISP=ISS(I) DO 86 K=2,LISP IF(IHEX.LT.9) ICELSP=ICELSP+MAXSP-MINSP+1 DO 82 J=1,NCELAP IAUX=IAUX+1 IF(IHEX.LT.9) THEN IAD(IAUX+1)=IBB(JAUX+J)+ICELSP IDD(IAUX+1)=ICC(IBB(JAUX+J)) IDD(NCELA+IAUX+1)=ISS(NCEL+IBB(JAUX+J)) ELSE IAD(IAUX+1)=IAUX+1 IDD(IAUX+1)=ICC(JAUX+J) IDD(NCELA+IAUX+1)=ICC(NCEL+JAUX+J) ENDIF 82 CONTINUE 86 CONTINUE ENDIF JAUX=JAUX+NCELAP 85 CONTINUE * * DUPLICATION DE TURN * MBB=NCELA+NCELA IF(LGTURN) THEN IAUX=2*NCEL JAUX=0 DO 95 I=1,LZ IF(IHEX.LT.9) THEN CALL DUTURN(IHEX,ICC(IAUX+1),NCELP,IDD(MBB+JAUX+1), + NCELAP,IBB) ELSE DO 87 IV=1,NCELAP IDD(MBB+JAUX+IV)=ICC(IAUX+IV) 87 CONTINUE ENDIF IAUX=IAUX+NCELP KAUX=JAUX-1 JAUX=JAUX+NCELAP IF(LSPLIT) THEN LISP=ISS(I) DO 92 J=2,LISP DO 90 K=1,NCELAP IDD(MBB+JAUX+1)=IDD(MBB+KAUX+K+1) JAUX=JAUX+1 90 CONTINUE 92 CONTINUE ENDIF 95 CONTINUE DEALLOCATE(ISS) ENDIF IF(IHEX.NE.9) DEALLOCATE(IBB) DEALLOCATE(ICC) IF(NCODE(5) .EQ. 5 .OR. NCODE(5) .EQ. 10) THEN * * DUPLICATION DE LA SYMETRIE SELON L'AXE Z- * IF(NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10) CALL XABORT( > 'LHXUNH: ONLY ONE Z SYMETRY IS PERMITED') IF(NCODE(6) .EQ. 5) THEN KBB=NCELA+NCELA-NCELAP*LSPLZM IOFZD=LSPLZM ELSE KBB=NCELA+NCELA IOFZD=0 ENDIF MCODE=1 KK=KBB KBB=2*KBB IF(LGTURN)KBB=KBB+KK ALLOCATE(IGG(KBB),IAA(KK)) IAUX=0 JAUX=NCELA-NCELAP LAUX=2*NCELA-NCELAP * * DUPLICATION DE MIX ET MERGE * NCOUR=IFCOUR(NCELAP) DO 110 I=IOFZD,LZZ-1 IPOS=0 IAA(IAUX+1)=IAD(JAUX+1) IGG(IAUX+1)=IDD(JAUX+1) IGG(KK+IAUX+1)=IDD(LAUX+1) DO 100 J1=2,NCOUR DO 99 J=IFONC(J1,5)-1,IFONC(J1,0)-1,-1 IPOS=IPOS+1 IAA(IAUX+IPOS+1)=IAD(JAUX+J+1) IGG(IAUX+IPOS+1)=IDD(JAUX+J+1) IGG(KK+IAUX+IPOS+1)=IDD(LAUX+J+1) 99 CONTINUE NCLCOR=1+3*J1*(J1-1) DO 105 J=NCLCOR-1,IFONC(J1,5),-1 IPOS=IPOS+1 IAA(IAUX+IPOS+1)=IAD(JAUX+J+1) IGG(IAUX+IPOS+1)=IDD(JAUX+J+1) IGG(KK+IAUX+IPOS+1)=IDD(LAUX+J+1) 105 CONTINUE 100 CONTINUE IAUX=IAUX+NCELAP JAUX=JAUX-NCELAP LAUX=LAUX-NCELAP 110 CONTINUE DO 115 K=1,NCELA IAA(IAUX+K)=IAD(K) IGG(IAUX+K)=IDD(K) IGG(KK+IAUX+K)=IDD(NCELA+K) 115 CONTINUE * * DUPLICATION DE TURN * IF(LGTURN) THEN IAUX=0 LAUX=3*NCELA-NCELAP*IOFZD DO 130 I=IOFZD,LZZ-1 J=-1 JAUX2=0 JAUX1=0 DO 120 J1=1,NCOUR LGPASS=.TRUE. 118 CONTINUE DO 119 J2=JAUX2,JAUX1,-1 J=J+1 ITURN=IDD(LAUX+J2+1) IF(ITURN.LE.6) THEN IF(ITURN.EQ.1) THEN IGG(2*KK+IAUX+J+1)=12 ELSEIF(ITURN.EQ.2) THEN IGG(2*KK+IAUX+J+1)=11 ELSEIF(ITURN.EQ.3) THEN IGG(2*KK+IAUX+J+1)=10 ELSEIF(ITURN.EQ.4) THEN IGG(2*KK+IAUX+J+1)=9 ELSEIF(ITURN.EQ.5) THEN IGG(2*KK+IAUX+J+1)=8 ELSEIF(ITURN.EQ.6) THEN IGG(2*KK+IAUX+J+1)=7 ENDIF ELSEIF(ITURN.LE.12) THEN IF(ITURN.EQ.12) THEN IGG(2*KK+IAUX+J+1)=1 ELSEIF(ITURN.EQ.11) THEN IGG(2*KK+IAUX+J+1)=2 ELSEIF(ITURN.EQ.10) THEN IGG(2*KK+IAUX+J+1)=3 ELSEIF(ITURN.EQ.9) THEN IGG(2*KK+IAUX+J+1)=4 ELSEIF(ITURN.EQ.8) THEN IGG(2*KK+IAUX+J+1)=5 ELSEIF(ITURN.EQ.7) THEN IGG(2*KK+IAUX+J+1)=6 ENDIF ELSE CALL XABORT('LHXUNH: EXPECTED VALUE OF TURN ') ENDIF 119 CONTINUE IF(LGPASS) THEN JAUX2=1+3*J1*(J1-1)-1 JAUX1=IFONC(J1,5) LGPASS=.FALSE. IF(J1.GT.1) GOTO 118 ENDIF JAUX2=IFONC(J1+1,5)-1 JAUX1=IFONC(J1+1,0)-1 120 CONTINUE IAUX=IAUX+NCELAP LAUX=LAUX-NCELAP 130 CONTINUE ENDIF DO 135 K=1,NCELA IGG(2*KK+IAUX+K)=IDD(2*NCELA+K) 135 CONTINUE IPLANI=LZZ LZZ=2*LZZ-IOFZD ELSEIF(NCODE(6) .EQ. 5 .OR. NCODE(6) .EQ. 10) THEN * * DULPLICATION DE LA GEOMETRIE SELON Z+ * IF(NCODE(6) .EQ. 5) THEN KBB=NCELA+NCELA-NCELAP*LSPLZP IOFZD=LSPLZP ELSE KBB=NCELA+NCELA IOFZD=0 ENDIF MCODE=2 KK=KBB KBB=2*KBB IF(LGTURN)KBB=KBB+KK ALLOCATE(IGG(KBB),IAA(KK)) * * DUPLICATION DE MIX ET MERGE * DO 140 I=1,NCELA IAA(I)=IAD(I) IGG(I)=IDD(I) IGG(KK+I)=IDD(NCELA+I) 140 CONTINUE NCOUR=IFCOUR(NCELAP) LFIN=-NCELAP*IOFZD+NCELA IPOS=-1 DO 145 I=IOFZD,LZZ-1 LFIN=LFIN-NCELAP IPOS=IPOS+1 IAA(NCELA+IPOS+1)=IAD(LFIN+1) IGG(NCELA+IPOS+1)=IDD(LFIN+1) IGG(KK+NCELA+IPOS+1)=IDD(NCELA+LFIN+1) DO 143 J1=2,NCOUR DO 141 J=IFONC(J1,5)-1,IFONC(J1,0)-1,-1 IPOS=IPOS+1 IAA(NCELA+IPOS+1)=IAD(LFIN+J+1) IGG(NCELA+IPOS+1)=IDD(LFIN+J+1) IGG(KK+NCELA+IPOS+1)=IDD(NCELA+LFIN+J+1) 141 CONTINUE NCLCOR=1+3*J1*(J1-1) DO 142 J=NCLCOR-1,IFONC(J1,5),-1 IPOS=IPOS+1 IAA(NCELA+IPOS+1)=IAD(LFIN+J+1) IGG(NCELA+IPOS+1)=IDD(LFIN+J+1) IGG(KK+NCELA+IPOS+1)=IDD(NCELA+LFIN+J+1) 142 CONTINUE 143 CONTINUE 145 CONTINUE * * DUPLICATION DE TURN * IF(LGTURN) THEN DO 150 I=1,NCELA IGG(2*KK+I)=IDD(2*NCELA+I) 150 CONTINUE LFIN=-NCELAP*IOFZD+NCELA J=-1+NCELA DO 155 JP=IOFZD,LZZ-1 LFIN=LFIN-NCELAP JAUX2=0 JAUX1=0 DO 154 J1=1,NCOUR LGPASS=.TRUE. 152 CONTINUE DO 153 J2=JAUX2,JAUX1,-1 J=J+1 ITURN=IDD(2*NCELA+LFIN+J2+1) IF(ITURN.LE.6) THEN IF(ITURN.EQ.1) THEN IGG(2*KK+J+1)=12 ELSEIF(ITURN.EQ.2) THEN IGG(2*KK+J+1)=11 ELSEIF(ITURN.EQ.3) THEN IGG(2*KK+J+1)=10 ELSEIF(ITURN.EQ.4) THEN IGG(2*KK+J+1)=9 ELSEIF(ITURN.EQ.5) THEN IGG(2*KK+J+1)=8 ELSEIF(ITURN.EQ.6) THEN IGG(2*KK+J+1)=7 ENDIF ELSEIF(ITURN.LE.12) THEN IF(ITURN.EQ.12) THEN IGG(2*KK+J+1)=1 ELSEIF(ITURN.EQ.11) THEN IGG(2*KK+J+1)=2 ELSEIF(ITURN.EQ.10) THEN IGG(2*KK+J+1)=3 ELSEIF(ITURN.EQ.9) THEN IGG(2*KK+J+1)=4 ELSEIF(ITURN.EQ.8) THEN IGG(2*KK+J+1)=5 ELSEIF(ITURN.EQ.7) THEN IGG(2*KK+J+1)=6 ENDIF ELSE CALL XABORT('LHXUNH: EXPECTED VALUE OF TURN ') ENDIF 153 CONTINUE IF(LGPASS) THEN JAUX2=1+3*J1*(J1-1)-1 JAUX1=IFONC(J1,5) LGPASS=.FALSE. IF(J1.GT.1) GOTO 152 ENDIF JAUX2=IFONC(J1+1,5)-1 JAUX1=IFONC(J1+1,0)-1 154 CONTINUE 155 CONTINUE ENDIF IPLANI=LZZ LZZ=2*LZZ-IOFZD ELSE ALLOCATE(IGG(NBASE),IAA(NCELA)) DO 156 J=1,NBASE IGG(J)=IDD(J) 156 CONTINUE DO 157 J=1,NCELA IAA(J)=IAD(J) 157 CONTINUE KK=NCELA ENDIF DEALLOCATE(IDD,IAD) * * RESTORAGE DES DONNEES * NCELA=KK MVOSU=0 MVOLUM=0 MESH=3*KK NSMIN=0 NSMAX=0 ISURF=0 NCOUR=1 IF(NCELAP.GT.1)NCOUR=IFCOUR(NCELAP) ICELC0= IFONC(NCOUR,0) ICELC1= IFONC(NCOUR,1)-ICELC0 MCOU=1 LCOU=1 ALLOCATE(SURL(2*LZZ)) SURL(:2*LZZ)=0 IF(LGCELL) THEN CALL LCMSIX(IPTRK,'DATA_DUP',1) CALL LCMPUT(IPTRK,'GENER0',KK,1,IAA) CALL LCMPUT(IPTRK,'GENERATING',KK,1,IGG) CALL LCMSIX(IPTRK,' ',2) DEALLOCATE(IAA) NRAY=0 NCDP=NCELA-NCELAP ICELL1=IFONC(NCOUR,5) IP=1 ISAUX=0 DO 200 I=0,KK-1 KRAY=ISEC1(IGG(I+1)) NRAY=NRAY+KRAY I1=I+1 DO 205 JR=1,KRAY+1 KSECT=ISEC2(IGG(I+1))%ILOCR(JR) IF(KSECT.GT.1) THEN MSEC=6*(KSECT-1) MVOSU=MVOSU+MSEC IF(I1.LE.NCELAP)THEN NSMIN=NSMIN+MSEC ELSEIF(I1.GT.NCDP) THEN NSMAX=NSMAX+MSEC ENDIF ELSE MVOSU=MVOSU+1 IF(I1.LE.NCELAP)THEN NSMIN=NSMIN+1 ELSEIF(I1.GT.NCDP) THEN NSMAX=NSMAX+1 ENDIF ENDIF 205 CONTINUE IF(IHEX.EQ.9) THEN IF(MCODE.EQ.1) THEN IF(I1.LE.NCELAP) THEN IF(I1.LE.LCOU) THEN VLAT(MCOU)=NSMIN IF(I1.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMIN ELSE LCOU=LCOU+6*MCOU MCOU=MCOU+1 ENDIF ENDIF ELSEIF(MCODE.EQ.2) THEN IF(I1.GT.NCDP) THEN I2=I1-NCDP IF(I2.LE.LCOU) THEN VLAT(MCOU)=NSMAX IF(I2.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMAX ELSE LCOU=LCOU+6*MCOU MCOU=MCOU+1 ENDIF ENDIF ENDIF ENDIF ICOX=INT(AINT(REAL(I1)/REAL(NCELAP))) IF(MOD(I1,NCELAP).NE.0)ICOX=ICOX+1 ICOX=ICOX-1 ICX=NCELAP*ICOX ICELC=ICELC0+ICX ICLIM=NCELAP+ICX IF(I1.GE.ICELC.AND.I1.LE.ICLIM) THEN IF(KSECT.GT.1) THEN ISURF=ISURF+2*(KSECT-1) ISURF0=ISURF IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+KSECT-1 IF(I1.LE.NCELAP*IP) THEN NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX SURL(IP)=ISURF ELSE ISAUX=0 IP=IP+1 NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 ENDIF ELSE ISURF=ISURF+2 ISURF0=ISURF IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+1 IF(I1.LE.NCELAP*IP) THEN NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=1 IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX SURL(IP)=ISURF ELSE ISAUX=0 IP=IP+1 NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=1 ENDIF ENDIF ENDIF MVOLUM=MVOLUM+KRAY+1 200 CONTINUE DO 206 I=1,ISTAT9 DEALLOCATE(ISEC2(I)%ILOCR) 206 CONTINUE MESH=MESH+NRAY IF(IPLANZ.EQ.1) NSMAX=NSMIN ELSE CALL LCMSIX(IPTRK,'DATA_DUP',1) CALL LCMPUT(IPTRK,'MIX',KK,1,IGG) CALL LCMSIX(IPTRK,' ',2) NCDP=NCELA-NCELAP MVOLUM=KK NCOUR=IFCOUR(NCELAP) ICELL1=IFONC(NCOUR,5) IP=1 ISAUX=0 DO 210 I=0,KK-1 I1=I+1 KSECT=ISEC1(IGG(I+1)) ICOX=INT(AINT(REAL(I1)/REAL(NCELAP))) IF(MOD(I1,NCELAP).NE.0)ICOX=ICOX+1 ICOX=ICOX-1 ICXX=NCELAP*ICOX ICELC=ICELC0+ICXX ICLIM=NCELAP+ICXX IF(KSECT.GT.1) THEN MSEC=6*(KSECT-1) MVOSU=MVOSU+MSEC IF(I1.LE.NCELAP)THEN NSMIN=NSMIN+MSEC ELSEIF(I1.GT.NCDP) THEN NSMAX=NSMAX+MSEC ENDIF IF(I1.GE.ICELC.AND.I1.LE.ICLIM) THEN ISURF=ISURF+2*(KSECT-1) ISURF0=ISURF IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+KSECT-1 IF(I1.LE.NCELAP*IP) THEN NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX SURL(IP)=ISURF ELSE ISAUX=0 IP=IP+1 NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=KSECT-1 ENDIF ENDIF ELSE MVOSU=MVOSU+1 IF(I1.LE.NCELAP)THEN NSMIN=NSMIN+1 ELSEIF(I1.GT.NCDP) THEN NSMAX=NSMAX+1 ENDIF IF(I1.GE.ICELC.AND.I1.LE.ICLIM) THEN ISURF=ISURF+2 ISURF0=ISURF IF(MOD(I1-ICELC,ICELC1).EQ.0)ISURF=ISURF+1 IF(I1.LE.NCELAP*IP) THEN NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=1 IF(I1.EQ.ICELL1+NXX) SURL(LZZ+IP)=ISURF0-ISAUX SURL(IP)=ISURF ELSE ISAUX=0 IP=IP+1 NXX=NCELAP*(IP-1) IF(I1.EQ.ICELC0+NXX) ISAUX=1 ENDIF ENDIF ENDIF IF(IHEX.EQ.9) THEN IF(MCODE.EQ.1) THEN IF(I1.LE.NCELAP) THEN IF(I1.LE.LCOU) THEN VLAT(MCOU)=NSMIN IF(I1.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMIN ELSE LCOU=LCOU+6*MCOU MCOU=MCOU+1 ENDIF ENDIF ELSEIF(MCODE.EQ.2) THEN IF(I1.GT.NCDP) THEN I2=I1-NCDP IF(I2.LE.LCOU) THEN VLAT(MCOU)=NSMAX IF(I2.EQ.IFONC(MCOU,5)) VLAT(NCOUR+MCOU)=NSMAX ELSE LCOU=LCOU+6*MCOU MCOU=MCOU+1 ENDIF ENDIF ENDIF ENDIF 210 CONTINUE IF(IPLANZ.EQ.1) NSMAX=NSMIN ENDIF DEALLOCATE(ISEC2,ISEC1) CALL LCMSIX(IPTRK,'DATA_DUP',1) CALL LCMPUT(IPTRK,'SURL_HEX',2*LZZ,1,SURL) CALL LCMPUT(IPTRK,'MERGE',KK,1,IGG(KK+1)) IF(LGTURN)CALL LCMPUT(IPTRK,'TURN',KK,1,IGG(2*KK+1)) CALL LCMSIX(IPTRK,' ',2) DEALLOCATE(IGG,SURL) * * MODIFICATION DU VECTEUR STATE * ISTATE(5)=LZZ IPLANZ=LZZ ENDIF ISTATE(3)=NCELAP ISURF=ISURF+NSMIN+NSMAX RETURN END