Sources Esope | Cast3M

triso
C TRISO     SOURCE    PV090527  26/09/08    21:15:12     12640          
C
      SUBROUTINE TRISO(VCHC,XX,YY,ZZ,VV,NPT,NISO)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                 C
C         TRACER DES ISOVALEURS D UN CHAMPOINT                    C
C                PAR COLORIAGE DE ZONE                            C
C                OU PAR TRACE DE LIGNE EN COULEUR (SELON ISOTYP   C
C                                                                 C
C                                                                 C
C              AOUT 85                                            C
C                                                                 C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      REAL   VCHC
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC CCGEOME
-INC CCTRACE
C
      PARAMETER (NTR=10)
      LOGICAL RANGE,IDEP
      DIMENSION VCHC(*),XTR(NTR),YTR(NTR),ZTR(NTR)
      DIMENSION ROUG(NTR),VERT(NTR),BLEU(NTR)
      dimension xx(*),yy(*),vv(*),zz(*),vvn(8)
      real*8 vdiff,up,upos,xxx
*
*      RANGE(XXX)= XXX.GE.-0.000001.AND.XXX.LE.1.000001
      RANGE(XXX)= XXX.GE.(-xszpre).AND.XXX.LE.(1.+xszpre)
 
*      write(ioimp,*) 'coucou triso, npt,niso=',npt,niso
      VSTART=-xsgran
      VFINAL= xsgran
      VALHAU=VSTART
      if (iogra.eq.6) then
         valbas=vchc(1)
*goo       valhau=vchc(niso)
         valhau=vchc(max(niso-1,1))
         do 300 i=1,npt
            vvn(i)=(vv(i)-valbas)/(valhau-valbas)
 300     continue
C        Calcul des couleurs depuis la palette
         DO I=1,NPT
           XALFA=VVN(I)
           CALL PALET3(XALFA,IPALET,R1,V1,B1)
           ROUG(I)=R1
           VERT(I)=V1
           BLEU(I)=B1
         ENDDO
         CALL OGLTRISO(XX,YY,ZZ,VVN,NPT,ROUG,VERT,BLEU)
      endif
      IF (ISOTYP.GT.0.and.iogra.ne.6) THEN
         DO 50 KK=1,NISO
            VALBAS=VALHAU
            VALHAU=VFINAL
*      IF (KK.NE.NISO) VALHAU=(VCHC(KK)+VCHC(KK+1))/2
*      TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))/1e+2
            IF (KK.NE.NISO) VALHAU=VCHC(KK)
*      TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))/1e+2
            TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))*xszpre
            toll=max(xspeti,toll)
            NP=0
C  VALBAS ET VALHAU SONT LES FRONTIERES DE LA ZONE A COLORIER
C  JE CRAINS QU'IL FAILLE RECENSER LES CAS POSSIBLES
C  LE POINT EST IL DANS LA ZONE  ?
            do 10 ipt=1,npt
               iptn=ipt+1
               if (iptn.gt.npt) iptn=1
               IF (VALBAS-toll.LE.VV(IPT).AND.VALHAU+toll.GE.VV(IPT))
     $              THEN
                  NP=NP+1
                  if (npt.eq.2.and.np.gt.2) np=2
                  XTR(NP)=XX(IPT)
                  YTR(NP)=YY(IPT)
                  ZTR(NP)=ZZ(IPT)
               ENDIF
               if (npt.eq.2.and.ipt.eq.2) goto 10
C  RENCONTRE-T-ON VALHAU OU VALBAS EN ALLANT VERS le point suivant
               vdiff=sign(max(toll,abs(vv(iptn)-vv(ipt))),vv(iptn)
     $              -vv(ipt))
               UPOSH=(VALHAU-VV(ipt))*sign(1.d0,vdiff)
               UPOSB=(VALBAS-VV(ipt))*sign(1.d0,vdiff)
               UP=MIN(UPOSH,UPOSB)
                  up=max(-2*abs(vdiff),up)
                  up=min(2*abs(vdiff),up)
                  UP=UP/abs(VDIFF)
               IF (RANGE(UP)) THEN
                  NP=NP+1
                  if (npt.eq.2.and.np.gt.2) np=2
                  XTR(NP)=XX(ipt)+UP*(XX(iptn)-XX(ipt))
                  YTR(NP)=YY(ipt)+UP*(YY(iptn)-YY(ipt))
                  ZTR(NP)=ZZ(ipt)+UP*(ZZ(iptn)-ZZ(ipt))
               ENDIF
               UP=MAX(UPOSH,UPOSB)
                  up=max(-2*abs(vdiff),up)
                  up=min(2*abs(vdiff),up)
                  UP=UP/abs(VDIFF)
               IF (RANGE(UP)) THEN
                  NP=NP+1
                  if (npt.eq.2.and.np.gt.2) np=2
                  XTR(NP)=XX(ipt)+UP*(XX(iptn)-XX(ipt))
                  YTR(NP)=YY(ipt)+UP*(YY(iptn)-YY(ipt))
                  ZTR(NP)=ZZ(ipt)+UP*(ZZ(iptn)-ZZ(ipt))
               ENDIF
C ON TRACE LE RESULTAT
 10         continue
            IF (NP.NE.0) THEN
               if (niso.lt.16) then
c           CALL TRAISO(NP,XTR,YTR,ICOTAB(KK*(2-NISO/8)))
                  CALL TRAISO(NP,XTR,YTR,ICOTAB(ISOTAB(KK,NISO)))
               else
                  CALL TRAISO(NP,XTR,YTR,KK)
               endif
            ENDIF
 50      CONTINUE
         IF (ISOTYP.EQ.2) THEN
*            call chcoul(8)
            call chcoul(IDNOIR)
            DO 250 KK=1,NISO-1
*      TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))/1e+3
*       VALDES = (VCHC(KK)+VCHC(KK+1))/2
*      TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))/1e+3
               TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))*xszpre
               VALDES = VCHC(KK)
               IDEP=.TRUE.
               do 220 ipt=1,npt
                  iptn=ipt+1
                  if (iptn.gt.npt) iptn=1
                  UPOS=-1.
                  IF (ABS(VV(iptn)-VV(ipt)).GT.TOLL)
     *                 UPOS=(VALDES-VV(ipt))/(VV(iptn)-VV(ipt))
                  IF (RANGE(UPOS)) THEN
                     IF (IDEP) THEN
                        XTR(1)=XX(ipt)+UPOS*(XX(iptn)-XX(ipt))
                        YTR(1)=YY(ipt)+UPOS*(YY(iptn)-YY(ipt))
                        ZTR(1)=ZZ(ipt)+UPOS*(ZZ(iptn)-ZZ(ipt))
                        IDEP=.FALSE.
                     ELSE
                        XTR(2)=XX(ipt)+UPOS*(XX(iptn)-XX(ipt))
                        YTR(2)=YY(ipt)+UPOS*(YY(iptn)-YY(ipt))
                        ZTR(2)=ZZ(ipt)+UPOS*(ZZ(iptn)-ZZ(ipt))
                        CALL POLRL(2,XTR,YTR,ZTR)
*           GOTO 150
                     ENDIF
                  ENDIF
 220           continue
 250        CONTINUE
         ENDIF
      ELSEIF (iogra.ne.6) THEN
         DO 150 KK=1,NISO
*      TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))/1e+3
            TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))*xszpre
            VALDES = VCHC(KK)
            IDEP=.TRUE.
            do 20 ipt=1,npt
               iptn=ipt+1
               if (iptn.gt.npt) iptn=1
               UPOS=-1.
               IF (ABS(VV(iptn)-VV(ipt)).GT.TOLL)
     *              UPOS=(VALDES-VV(ipt))/(VV(iptn)-VV(ipt))
               IF (RANGE(UPOS)) THEN
                  IF (IDEP) THEN
                     if (niso.lt.13) then
*sg                     if (niso.lt.16) then
*sg                        CALL CHCOUL(ICOTAB(KK*(2-NISO/8)))
                        CALL CHCOUL(ICOTAB(ISOTA0(KK,NISO)))
                     else
                        CALL CHCOUL(ICOTAB(MOD(KK,12)+1))
*sg                        CALL CHCOUL(KK)
                     endif
                     XTR(1)=XX(ipt)+UPOS*(XX(iptn)-XX(ipt))
                     YTR(1)=YY(ipt)+UPOS*(YY(iptn)-YY(ipt))
                     ZTR(1)=ZZ(ipt)+UPOS*(ZZ(iptn)-ZZ(ipt))
                     IDEP=.FALSE.
                  ELSE
                     XTR(2)=XX(ipt)+UPOS*(XX(iptn)-XX(ipt))
                     YTR(2)=YY(ipt)+UPOS*(YY(iptn)-YY(ipt))
                     ZTR(2)=ZZ(ipt)+UPOS*(ZZ(iptn)-ZZ(ipt))
                     CALL POLRL(2,XTR,YTR,ZTR)
*           GOTO 150
                  ENDIF
               ENDIF
 20         continue
 150     CONTINUE
      ENDIF
      RETURN
      END