Sources Esope | Cast3M

trisup
C TRISUP    SOURCE    CB215821  16/07/18    21:15:01     9033           
C   ISSUS DE COCO  SUPER TRI
C
      SUBROUTINE TRISUP(NUMNP,PREC,NG,TRUC,TRUC1,CRIT,XMIN,YMIN,ZMIN,
     #     STRAV)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
      SEGMENT /STRAV/(NP1(ITE),NP2(ITE),NP3(ITE),NPI(ITE),IDCP(ITE),
     &                NP4(ITE),NP5(ITE))
      INTEGER TRUC,TRUC1,TRUC2,TRUC3
      IDIMP1=IDIM+1
      NF=3
      NUMNP3=NUMNP+3+1
      ANF=NF*NUMNP
      IREF=IDCP(1)*IDIMP1-IDIM
      XMAX=XCOOR(IREF)
      XMIN=XMAX
      IF (IDIM.EQ.3) THEN
         YMAX=XCOOR(IREF+1)
         YMIN=YMAX
         ZMAX=XCOOR(IREF+2)
         ZMIN=ZMAX
         DO 13 I=2,NUMNP
            IREF=IDCP(I)*IDIMP1-IDIM
            ZZ=XCOOR(IREF)
            XMIN=MIN(XMIN,ZZ)
            XMAX=MAX(XMAX,ZZ)
            ZZ=XCOOR(IREF+1)
            YMIN=MIN(YMIN,ZZ)
            YMAX=MAX(YMAX,ZZ)
            ZZ=XCOOR(IREF+2)
            ZMIN=MIN(ZMIN,ZZ)
            ZMAX=MAX(ZMAX,ZZ)
 13      CONTINUE
      ELSE IF (IDIM.EQ.2) THEN
         YMAX=XCOOR(IREF+1)
         YMIN=YMAX
         DO 12 I=2,NUMNP
            IREF=IDCP(I)*IDIMP1-IDIM
            ZZ=XCOOR(IREF)
            XMIN=MIN(XMIN,ZZ)
            XMAX=MAX(XMAX,ZZ)
            ZZ=XCOOR(IREF+1)
            YMIN=MIN(YMIN,ZZ)
            YMAX=MAX(YMAX,ZZ)
 12      CONTINUE
         ZMIN=0.D0
         ZMAX=0.D0
C*    ELSE IF (IDIM.EQ.1) THEN
      ELSE
         DO 11 I=2,NUMNP
           IREF=IDCP(I)*IDIMP1-IDIM
           ZZ=XCOOR(IREF)
           XMIN=MIN(XMIN,ZZ)
           XMAX=MAX(XMAX,ZZ)
 11      CONTINUE
         YMIN=0.D0
         YMAX=0.D0
         ZMIN=0.D0
         ZMAX=0.D0
      ENDIF
      DISTZA=(XMAX-XMIN)/PREC
      DISTZB=(YMAX-YMIN)/PREC
      DISTZC=(ZMAX-ZMIN)/PREC
 
      NPUI = 3
      IF(DISTZA.LT.(DISTZB*1.D-5).OR.DISTZA.LT.DISTZC*1.D-5) NPUI=NPUI-1
      IF(DISTZB.LT.(DISTZA*1.D-5).OR.DISTZB.LT.DISTZC*1.D-5) NPUI=NPUI-1
      IF(DISTZC.LT.(DISTZA*1.D-5).OR.DISTZC.LT.DISTZB*1.D-5) NPUI=NPUI-1
      IF (NPUI .EQ. 0) THEN
        CALL ERREUR(5)
        RETURN
      ENDIF
      A=(DISTZA+1)*(DISTZB+1)*(DISTZC+1)
      RAP=1.D0
      IF (A.GT.ANF) RAP=(ANF/A)**(1.D0/REAL(NPUI))
      TRUC =INT(DISTZA*RAP)+3
      TRUC1=INT(DISTZB*RAP)+3
      TRUC2=INT(DISTZC*RAP)+3
      TRUC3=TRUC*TRUC1
      CRIT=PREC/RAP*1.0001D0
      NG=TRUC3*TRUC2/NUMNP+1
      DO 20 I=1,NUMNP3
         NP1(I)=0
 20   CONTINUE
      YCOR=0.D0
      ZCOR=0.D0
      DO 25 I=1,NUMNP
         IREF=IDCP(I)*IDIMP1-IDIM
         IF (IDIM.GE.2) YCOR=XCOOR(IREF+1)
         IF (IDIM.GE.3) ZCOR=XCOOR(IREF+2)
         ICRAT= INT((XCOOR(IREF)-XMIN)/CRIT+2)
     .         +INT((YCOR-YMIN)/CRIT+1)*TRUC
     .         +INT((ZCOR-ZMIN)/CRIT+1)*TRUC3
         NZONE=ICRAT/NG+1
         NP4(I)=ICRAT
         NP5(I)=NZONE
         NP1(NZONE)=NP1(NZONE)+1
 25   CONTINUE
      DO 30 I=2,NUMNP3
         NP1(I)=NP1(I-1)+NP1(I)
 30   CONTINUE
      DO 35 I=1,NUMNP
         ICRAT=NP4(I)
         NZONE=NP5(I)
         J=NP1(NZONE)
         NP3(J)=ICRAT
         NP2(J)=I
         NP1(NZONE)=NP1(NZONE)-1
 35   CONTINUE
      DO 40 I=1,NUMNP3-1
         JD=NP1(I)+2
         JF=NP1(I+1)
         IF (JD.LE.JF) THEN
 45         IPERM=0
            DO 50 J=JD,JF
               IF (NP3(J-1).GT.NP3(J)) THEN
                  L1=NP2(J-1)
                  NP2(J-1)=NP2(J)
                  NP2(J)=L1
                  L1=NP3(J-1)
                  NP3(J-1)=NP3(J)
                  NP3(J)=L1
                  IPERM=1
               ENDIF
 50         CONTINUE
            IF (IPERM.EQ.1) GO TO 45
         ENDIF
 40   CONTINUE
      IF (IIMPI.NE.0) WRITE (IOIMP,41) DISTZA,DISTZB,DISTZC
 41   FORMAT (1X,' DISTZA=',F10.3,'DISTZB=',F10.3,'DISTZC=',F10.3)
      RETURN
      END