Télécharger la plaquette Cast3M


fr en

Télécharger aviso.eso

Retour à la liste

Numérotation des lignes : 

aviso

  1. C AVISO     SOURCE    CB215821  24/04/12    21:15:05     11897          
  2. C
  3.       SUBROUTINE AVISO(MELEME,MCHPOI,MCHAM,IPMO1,NISOD,
  4.      >    VCPCHA,VCHC,NISO,NCOUMA,VCHMIN,VCHMAX,MLREEL,MCARA,
  5.      >    NCOMP,LCOMP,COMPCH,choico)
  6. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  7. C
  8. C   Préparation du tracé des isovaleurs d un objet
  9. c   de type CHPOINT ou CHAMELEM
  10. C
  11. C   Création
  12. C     AOUT 85
  13. C
  14. C   Modifications :
  15. C      PM 09/11/2007 :
  16. C        . ne conserve que le nb d'isovaleurs admissibles
  17. C          si liste d'isovaleurs imposées
  18. C        . accepte une liste d'isovaleurs non croissante
  19. C
  20. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  21. C
  22.       IMPLICIT INTEGER(I-N)
  23.       SEGMENT VCPCHA(nbpts)
  24. -INC CCREEL
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC SMELEME
  29. -INC SMMODEL
  30. -INC SMCHPOI
  31. -INC SMCOORD
  32. -INC SMLREEL
  33. -INC SMCHAML
  34. -INC SMLMOTS
  35.       logical egar4
  36.       REAL VCHC
  37.       DIMENSION VCHC(*)
  38. c BP : indesou doit etre capable d'accueillir tous les nbsous modeles
  39.       SEGMENT indesou(nbinde)
  40. *     tableau des noms de composantes (chamelem)
  41.       CHARACTER*(*) COMPCH(*)
  42.       CHARACTER*(LOCOMP) CHOISI
  43.       INTEGER CHOICO
  44.       INTEGER NISOD
  45. C
  46.       NISO = NISOD
  47.  
  48.       DO I=1,VCPCHA(/1)
  49.          VCPCHA(I)=0
  50.       ENDDO
  51.  
  52. *     Cas du MCHAML
  53. *     =============
  54.       IF (MCHAM.NE.0) THEN
  55. *        Si ce sont des contraintes, on rajoute le Von Mises
  56.          MCHELM=MCHAM
  57.          SEGACT MCHELM
  58.          IUN=1
  59.          DO IU=1,ICHAML(/1)
  60.             MCHAML=ICHAML(IU)
  61.             SEGACT MCHAML
  62.             IF(IELVAL(/1).NE.1) IUN=0
  63.          ENDDO
  64.          IF (TITCHE.EQ.'CONTRAINTES'.AND.IUN.NE.1) THEN
  65. C Petit traitement pour retirer JOI1 du calcul de VMIS
  66.             MMODEL=IPMO1
  67.             SEGACT,MMODEL
  68.             N1=KMODEL(/1)
  69.             SEGINI,MMODE1
  70.             NN1=0
  71.             DO 3 IMO=1,N1
  72.               IMODEL=KMODEL(IMO)
  73.               SEGACT,IMODEL
  74.               IF(INFELE(13).EQ.75) GOTO 3
  75.               NN1=NN1+1
  76.               MMODE1.KMODEL(NN1)=IMODEL
  77.  3          CONTINUE
  78.             IF(NN1.EQ.0) THEN
  79.               SEGSUP,MMODE1
  80.             ELSE
  81.               N1=NN1
  82.               SEGADJ,MMODE1
  83.               IPMO1=MMODE1
  84.               isouc=1
  85.               CALL VMISPO(IPMO1,MCHELM,MCARA,ICONV,MCHEL1,IRET,isouc)
  86.               IF (IERR.NE.0) RETURN
  87.               SEGACT MCHEL1
  88.               DO 5 ISOUS=1,MCHEL1.IMACHE(/1)
  89.                  MCHAML=MCHEL1.ICHAML(ISOUS)
  90.                  SEGACT MCHAML*MOD
  91.                  NOMCHE(1)='VONMISES'
  92.  5            CONTINUE
  93.               CALL FUSCHL(MCHEL1,MCHELM,MCHELO)
  94.               MCHELM=MCHELO
  95.             ENDIF
  96.          ENDIF
  97.  
  98. *        On cree le MELEME a tracer
  99. *        On stocke les MELVAL dans LISREF (très astucieux)
  100.          SEGACT MCHELM
  101.          NBSOUS=IMACHE(/1)
  102.          NBREF=NBSOUS
  103.          NBNN=0
  104.          NBELEM=0
  105.          SEGINI MELEME
  106.          ITYPEL=0
  107.          DO ISOUS=1,NBSOUS
  108.             LISOUS(ISOUS)=IMACHE(ISOUS)
  109.          ENDDO
  110.          nbinde=NBSOUS
  111.          segini,indesou
  112. * kich : pour des modeles heterogenes (ex massif + poutre) pb de trace
  113.          ksou = 0
  114.          DO ISOUS=1,NBSOUS
  115.             IF (INFCHE(ISOUS,2).EQ.1.AND.INFCHE(ISOUS,6).NE.1) THEN
  116. *              pas un chamelem aux noeuds
  117.                CALL ERREUR(609)
  118.                RETURN
  119.             ENDIF
  120.             MCHAML=ICHAML(ISOUS)
  121.             SEGACT MCHAML
  122.  
  123. *           Constitution de la liste des noms de composantes COMPCH
  124. * kich : modif on crée une liste pour l ensemble du MCHELM
  125. *           NCOMP=0
  126.             CHOISI=' '
  127.             IF (LCOMP.NE.0) CHOISI=COMPCH(LCOMP)
  128.             IF (LCOMP.EQ.0) LCOMP=1
  129.             DO 25 ICOMP=1,TYPCHE(/2)
  130.                IF (TYPCHE(1).NE.'REAL*8') GOTO 25
  131.                DO JCOMP=1,NCOMP
  132.                   IF (COMPCH(JCOMP).EQ.NOMCHE(ICOMP)) GOTO 25
  133.                ENDDO
  134. *              COMPCH dimensionné à 10 dans PRTRAC
  135.                IF (NCOMP.EQ.10) GOTO 25
  136.                NCOMP=NCOMP+1
  137.                COMPCH(NCOMP)=NOMCHE(ICOMP)
  138.                IF (CHOISI.EQ.' ') CHOISI=NOMCHE(ICOMP)
  139.  25         CONTINUE
  140.             IF (NCOMP.EQ.0) THEN
  141. *           Il faut spécifier un champ par élément avec une seule composante
  142.                CALL ERREUR(320)
  143.                RETURN
  144.             ENDIF
  145. *           provisoirement
  146. *            DO JCOMP=1,NCOMP
  147. * kich : c est nomche qu il faut tester
  148.             DO  ICOMP=1,TYPCHE(/2)
  149. *               IF (COMPCH(JCOMP).EQ.CHOISI) LISREF(ISOUS)=IELVAL(JCOMP)
  150.                   IF (CHOISI.EQ.NOMCHE(ICOMP)) THEN
  151.                      LISREF(ISOUS)=IELVAL(ICOMP)
  152.                      ksou = ksou + 1
  153.                      indesou(ksou ) = isous
  154.                   ENDIF
  155.             ENDDO
  156.             IF (IERR.NE.0) RETURN
  157.          ENDDO
  158.  
  159. * verifie le meleme
  160.          do jso = 1 ,ksou
  161.           jsous = indesou(jso)
  162.           lisous(jso) = lisous(jsous)
  163.           lisref(jso) = lisref(jsous)
  164.           if (lisref(jso).eq.0) call erreur(5)
  165. c          write(6,*) 'verif', jso, lisous(jso),lisref(jso),lcomp
  166.          enddo
  167.          NBSOUS = ksou
  168.          NBREF = NBSOUS
  169.          segadj MELEME
  170.          segsup,indesou
  171.  
  172. *        Calcul des extrema
  173.          DO ISOUS=1,NBSOUS
  174.             MELVAL=LISREF(ISOUS)
  175.             IF (MELVAL.NE.0) THEN
  176.                SEGACT MELVAL
  177.                DO INN=1,VELCHE(/1)
  178.                   DO IEL=1,VELCHE(/2)
  179.                      VCHMIN=MIN(VCHMIN,REAL(VELCHE(INN,IEL)))
  180.                      VCHMAX=MAX(VCHMAX,REAL(VELCHE(INN,IEL)))
  181.                   ENDDO
  182.                ENDDO
  183.             ENDIF
  184.          ENDDO
  185.       ENDIF
  186.  
  187. *     Cas du CHPOINT
  188. *     ==============
  189.       IF (MCHAM.EQ.0) THEN
  190. *        Récupération des valeurs du champ à tracer
  191.          SEGACT MELEME
  192.          SEGACT MCHPOI
  193.          NSOUPO=IPCHP(/1)
  194.          if(lcomp.eq.0) then
  195.            ncomp=0
  196.            do isoupo=1,nsoupo
  197.              msoupo=ipchp(isoupo)
  198.              segact msoupo
  199.              do nbpp=1,nocomp(/2)
  200.                do ncbb=1,ncomp
  201.                  if( compch(ncbb).eq.nocomp(nbpp)) go to 43
  202.                enddo
  203. *              COMPCH dimensionné à 10 dans PRTRAC
  204.                IF (NCOMP.EQ.10) GOTO 43
  205.                ncomp=ncomp+1
  206.                compch(ncomp)=nocomp(nbpp)
  207.    43          continue
  208.              enddo
  209.            enddo
  210.            lcomp=1
  211.            if( (compch(1).eq.'LX  '. or . compch (1).eq.'FLX ' )
  212.      $     .and. ncomp.ge.2) lcomp=2
  213.          endif
  214.          choisi=compch(lcomp)
  215.          DO ISOUPO=1,NSOUPO
  216.             MSOUPO=IPCHP(ISOUPO)
  217.             SEGACT MSOUPO
  218.             MPOVAL=IPOVAL
  219.             SEGACT MPOVAL
  220.             IPT2=IGEOC
  221.             SEGACT IPT2
  222.             NCC=NOCOMP(/2)
  223.             do ic=1,ncc
  224.                if( choisi.eq.nocomp(ic)) go to 44
  225.             enddo
  226.             go to 45
  227.    44       continue
  228.             DO IEL=1,IPT2.NUM(/2)
  229.                IFOI=IPT2.NUM(1,IEL)
  230.                VCPCHA(IFOI)=VPOCHA(IEL,IC)
  231.             ENDDO
  232.    45       continue
  233.          ENDDO
  234.  
  235. *        Calcul des extrema
  236.          IPT1=MELEME
  237.          DO I=1,MAX(1,LISOUS(/1))
  238.             IF (LISOUS(/1).NE.0) IPT1=LISOUS(I)
  239.             SEGACT IPT1
  240.             DO J=1,IPT1.NUM(/1)
  241.                DO K=1,IPT1.NUM(/2)
  242.                   IPOIT=IPT1.NUM(J,K)
  243.                   VCHMIN=MIN(VCHMIN,REAL(VCPCHA(IPOIT)))
  244.                   VCHMAX=MAX(VCHMAX,REAL(VCPCHA(IPOIT)))
  245.                ENDDO
  246.             ENDDO
  247.          ENDDO
  248.       ENDIF
  249. C
  250. *     Détermination de la liste d'isovaleurs
  251. *     ======================================
  252. **--   par défaut
  253.       IF (ISOTYP.EQ.0) THEN
  254.          NISOMA=NCOUMA
  255.       ELSE
  256.          NISOMA=NCOUMA-1
  257.       ENDIF
  258.       IF (NISO.LE.0.OR.NISO.GT.NISOMA) NISO=NISOMA
  259. *--   d'après un LISTREEL en entrée
  260.       IF (MLREEL.EQ.0) CALL LIROBJ ('LISTREEL',MLREEL,0,IRETOU)
  261.       IF (IERR.NE.0) RETURN
  262.       IF (MLREEL.EQ.0) GOTO 9800
  263.  
  264. *PM   On s'assure d'avoir une liste croissante
  265.       SEGINI,MLREE1=MLREEL
  266.       CALL ORDO01(MLREE1.PROG,MLREE1.PROG(/1),.TRUE.)
  267.       SEGACT MLREEL
  268. *
  269.       NISO=PROG(/1)
  270.       IF (ISOTYP.GT.0) NISO=NISO+1
  271.       IF (NISO.LE.0) NISO=NISOMA
  272. *PM   Limitation du nb d'isovaleurs au nombre de couleurs admissibles
  273.       IF(NISO.GT.NISOMA) THEN
  274. *         write(IOIMP,*) 'ajustement à ',nisoma,' réels'
  275.          JG=NISOMA
  276.          SEGADJ, MLREE1
  277. *        on picore les valeurs parmi la liste entrée
  278.          IDI = PROG(/1) / JG
  279.          DO I=1,JG
  280.             MLREE1.PROG(I)=PROG(1+((I-1)*IDI))
  281.          ENDDO
  282.          NISO=NISOMA
  283. *         CALL ERREUR(201)
  284. *         GOTO 9099
  285.       ENDIF
  286.  
  287. *PM   PET=-1E30
  288.       DO I=1,MLREE1.PROG(/1)
  289.          VCHC(I)=MLREE1.PROG(I)
  290. *PM         IF (VCHC(I).LE.PET) THEN
  291. *PM*           Valeurs non croissantes dans la table
  292. *PM            CALL ERREUR(211)
  293. *PM            RETURN
  294. *PM         ELSE
  295. *PM            PET=MAX(PET,VCHC(I))
  296. *PM         ENDIF
  297.       ENDDO
  298. * Pas nécessaire ?
  299. *goo      IF (ISOTYP.GT.0) VCHC(NISO)=VCHMAX
  300.       SEGSUP MLREE1
  301.       GOTO 9099
  302.  
  303.  9800 CONTINUE
  304.  
  305. *--   Progression arithmétique entre les extrêmes
  306.  9900 CONTINUE
  307. C gounand 2018/10/09      
  308. C     Si la valeur max est approx egale au min, on utilise un VCHMA2
  309. C     legerement augmente par rapport à VCHMAX pour creer l'echelle de
  310. C     valeurs et avoir le champ en bleu.
  311. C     On ne modifie pas VCHMAX qui est la "vraie" valeur du max et qui
  312. C     sert ailleurs
  313. *ancien      IF (VCHMIN.EQ.VCHMAX) NISO=1
  314. *ancien      if(abs((VCHMAX - VCHMIN)/VCHMIN).LT.1D-5) NISO = 1
  315.       IF (EGAR4(VCHMIN,VCHMAX)) THEN
  316.          VCHMA2=VCHMAX+(MAX(MAX(ABS(VCHMAX),ABS(VCHMIN))*XSZPRE,XSPETI)
  317.      $        *NISO*2)
  318.       ELSE
  319.          VCHMA2=VCHMAX
  320.       ENDIF
  321. C
  322.       DO I=1,NISO+1
  323.          VCHC(I)=VCHMIN+I*(VCHMA2-VCHMIN)/(NISO+1)
  324.       ENDDO
  325. C     On essaie de repérer s'il y a des NaNQ
  326.       IF (.NOT.(VCHC(1).EQ.VCHC(1))) THEN
  327.          NISO=1
  328.          VCHC(1)=VCHMIN
  329.          VCHC(2)=VCHMA2
  330.       ENDIF
  331.  
  332. * gounand : sorti de aviso.eso NISO est en fait le nombre de
  333. *     couleurs demandees plutôt que le nombre d'isovaleurs demandees
  334.       IF (ISOTYP.GT.0) NISO=NISO+1
  335. *     Sortie
  336. *     ======
  337.  9099 CONTINUE
  338.  
  339.       END
  340.  
  341.  
  342.  
  343.  
  344.  
  345.  
  346.  
  347.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales