Télécharger la plaquette Cast3M


fr en

Télécharger sorfer.eso

Retour à la liste

Numérotation des lignes : 

sorfer

  1. C SORFER    SOURCE    CB215821  23/01/25    21:15:35     11573          
  2.       SUBROUTINE SORFER
  3.  
  4. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  5. C
  6. C But : Sortie d'un maillage et de CHPOINTs au format FER (ASCII)
  7. C
  8. C D'après : Michel Bulik (soravs)
  9. C         : Stephane Gounand (sortcp)
  10. C Adaptations : Gregory TURBELIN
  11. C          Octobre 1994 - Novembre 2002
  12. C
  13. C Appelé par : PRSORT
  14. C
  15. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  16.  
  17.       PARAMETER(NBMCLE=3)
  18.       CHARACTER*4 MTSCLE(NBMCLE)
  19.  
  20.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMCOORD
  24. -INC SMELEME
  25. -INC SMLCHPO
  26. -INC SMCHPOI
  27. -INC SMLMOTS
  28.  
  29.       POINTEUR MAPOIN.MELEME, MAELEM.MELEME
  30.       POINTEUR IPT10.MELEME, IPT11.MELEME
  31.  
  32.       POINTEUR NCMCHA.MLMOTS, NCCHPO.MLMOTS
  33.  
  34.  
  35. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  36. C
  37.       SEGMENT VALCHP
  38.          REAL*8 RVACHP(NBCCHP,NBNMAP)
  39.        END SEGMENT
  40. C
  41. C     Segment : VALeurs du CHPoint
  42. C
  43. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  44.  
  45.       SEGMENT IEQUIV
  46.          INTEGER LEQUIV(IECART)
  47.       END SEGMENT
  48.  
  49.        SEGMENT VALV
  50.           INTEGER IVALV(NBVALV)
  51.        END SEGMENT
  52.  
  53.       CHARACTER*8        MTYP,NOMTOT
  54.       CHARACTER*(LOCOMP) MOCOMP
  55.  
  56. C !!  CHARACTER*(LOCOMP) pour NUX NUY NUZ => JGN=LOCOMP (dans MLMOTS)
  57.       CHARACTER*(LOCOMP) NUX
  58.       CHARACTER*(LOCOMP) NUY
  59.       CHARACTER*(LOCOMP) NUZ
  60.  
  61.       REAL*8 VALTEM
  62.  
  63.       INTEGER NBCHPO
  64.       LOGICAL SORMAI, SORCHP, EXISEL, CNDTN
  65.       LOGICAL CMPINT
  66.       EXTERNAL CMPINT
  67.  
  68.       PARAMETER(LENTIT=40)
  69.       CHARACTER*(LENTIT) TITHED
  70.  
  71.       DATA MTSCLE/'TITR','SUIT','TEMP'/
  72.  
  73. C  Initialisation du titre par défaut
  74.       TITHED(1:LENTIT)='Sortie CAST3M  -> FERView      '
  75.  
  76.       NCCHPO=0
  77.       NCMCHA=0
  78.       VALCHP=0
  79.       IEQUIV=0
  80.  
  81.       SORMAI=.FALSE.
  82.       SORCHP=.FALSE.
  83.  
  84. C ... Recherche des objets à sortir ...
  85.  
  86.       CALL LIROBJ('MAILLAGE',IVAL,0,IRETOU)
  87.       IF(IRETOU.EQ.1) THEN
  88.         CALL ACTOBJ('MAILLAGE',IVAL,1)
  89.  
  90.          MELEME=IVAL
  91.          SORMAI=.TRUE.
  92.  
  93.          MAELEM=MELEME
  94.          EXISEL=.TRUE.
  95.  
  96.          MAPOIN=MAELEM
  97.          CALL CHANGE(MAPOIN,1)
  98. C    ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
  99.  
  100.       ENDIF
  101.  
  102. C ... Initialisation de la pile
  103.       N1 =0
  104.       SEGINI MLCHPO
  105.       IF(.NOT.SORMAI) THEN
  106.          GOTO 9996
  107.       ELSE
  108.  09   CONTINUE
  109.          CALL LIROBJ('CHPOINT ',IVAL,0,IRETOU)
  110.           IF(IRETOU.EQ.1) THEN
  111.              CALL ACTOBJ('CHPOINT ',IVAL,1)
  112.              ICHPOI(**)=IVAL
  113.              GOTO 09
  114.           ENDIF
  115.  
  116.          NBCHPO=ICHPOI(/1)
  117.          IF(NBCHPO.NE.0) THEN
  118.              SORCHP=.TRUE.
  119.          ENDIF
  120.       ENDIF
  121.  
  122. C ... Lecture des mots clés éventuels ...
  123.  
  124.       NBCGLO=0
  125.       INOREW=0
  126.       NENR=0
  127.       NBSUIT=1
  128.       NREW=1
  129.       VALTEM=0.D0
  130.  
  131.  10   CALL LIRMOT(MTSCLE,NBMCLE,IRAN,0)
  132.  
  133. C         'TITR'
  134.       IF (IRAN.EQ.1) THEN
  135.          CALL LIRCHA(TITHED(1:LENTIT),1,LCHAR)
  136.          IF (LCHAR.EQ.0) GOTO 9999
  137.  
  138. C         'SUIT'
  139.       ELSEIF(IRAN.EQ.2) THEN
  140.            INOREW=1
  141.         CALL LIRENT(NBSUIT,0,IRETOU)
  142.          IF(IRETOU.EQ.0)  THEN
  143.              NBSUIT = NBSUIT + 1
  144.          ENDIF
  145.  
  146. C         'TEMP'
  147.       ELSEIF(IRAN.EQ.3) THEN
  148.          NBCGLO=1
  149.          CALL LIRREE(VALTEM,1,IRETOU)
  150.          IF(IRETOU.EQ.0) GOTO 9999
  151.  
  152.       ENDIF
  153.  
  154.       IF(IRAN.NE.0) GOTO 10
  155.  
  156.       IF(INOREW.EQ.1.AND.VALTEM.EQ.0.D0) GOTO 9997
  157.  
  158. C ... NELMAI = Nombre d'ÉLéments du MAIllage ...
  159.       IF(EXISEL) THEN
  160.          CALL ECROBJ('MAILLAGE',MAELEM)
  161.          CALL NBEL
  162.          CALL LIRENT(NELMAI,1,IRETOU)
  163.          IF(IERR.NE.0) GOTO 9999
  164.       ELSE
  165.          NELMAI=0
  166.       ENDIF
  167.  
  168. C ... NBNMAP = NomBre de Noeuds du MAPoin ...
  169.       CALL ECROBJ('MAILLAGE',MAPOIN)
  170.       CALL NBNO
  171.       CALL LIRENT(NBNMAP,1,IRETOU)
  172.       IF(IERR.NE.0) GOTO 9999
  173.  
  174.  
  175. C ... Si le MAILLAGE et des CHPOINTs sont présents, on vérifiera que
  176. C     le MAILLAGE et le support du CHPOINT ont une partie commune ...
  177.  
  178.       IF(SORMAI.AND.SORCHP) THEN
  179.  
  180.       DO 20 ICH=1,NBCHPO
  181.           MCHPOI=ICHPOI(ICH)
  182.  
  183. C    ... IPT3 = support du CHPOINT ...
  184.          CALL ECRCHA('MAIL')
  185.          CALL ECROBJ('CHPOINT  ',MCHPOI)
  186.          CALL EXTRAI
  187.          CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  188.          IF(IERR.NE.0) GOTO 9999
  189.  
  190. C    ... NNSCHP = Nombre de Noeuds du Support du CHPoint ...
  191.          CALL ECROBJ('MAILLAGE',IPT3)
  192.          CALL NBNO
  193.          CALL LIRENT(NNSCHP,1,IRETOU)
  194.          IF(IERR.NE.0) GOTO 9999
  195.  
  196. C    ... Pour les explications de cette partie voir la partie
  197. C        équivalente dans SORTAVS.eso, au niveau du traitement du MCHAML ...
  198.          IF(NBNMAP.EQ.NNSCHP) THEN
  199.             SEGACT MAPOIN
  200.             SEGACT IPT3
  201.             NBEL1=MAPOIN.NUM(/2)
  202.             NBEL2=  IPT3.NUM(/2)
  203.             IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
  204. C          ... Le cas où les deux maillages sont simples ...
  205.                NBNN1=MAPOIN.NUM(/1)
  206.                NBNN2=  IPT3.NUM(/1)
  207.                IF((NBNN1.EQ.NBNN2).AND.(MAPOIN.ITYPEL.EQ.IPT3.ITYPEL))
  208.      &         THEN
  209.                   ILONG=NBEL1*NBNN1
  210.                   CNDTN=CMPINT(MAPOIN.NUM(1,1),IPT3.NUM(1,1),ILONG)
  211.                ELSE
  212.                   CNDTN=.FALSE.
  213.                ENDIF
  214.             ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
  215. C          ... Le cas où les deux maillages sont composés ...
  216.                NBS1=MAPOIN.LISOUS(/1)
  217.                NBS2=  IPT3.LISOUS(/1)
  218.                IF(NBS1.EQ.NBS2) THEN
  219.                   CNDTN=.TRUE.
  220.                   DO 1200 I=1,NBS1
  221.                      IPT10=MAPOIN.LISOUS(I)
  222.                      IPT11=  IPT3.LISOUS(I)
  223.                      SEGACT IPT10
  224.                      SEGACT IPT11
  225.                      IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
  226.      &                  (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
  227.      &                  (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
  228.                         ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
  229.                         CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
  230.      &                                         IPT11.NUM(1,1),ILONG)
  231.                      ELSE
  232.                         CNDTN=.FALSE.
  233.                      ENDIF
  234.  1200             CONTINUE
  235.                ELSE
  236.                   CNDTN=.FALSE.
  237.                ENDIF
  238.             ELSE
  239. C          ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
  240. C              probable quoique pas exclu que les deux maillages soient
  241. C              égaux, on met donc CoNDiTioN à FAUX ...
  242.                CNDTN=.FALSE.
  243.             ENDIF
  244.          ELSE
  245.             CNDTN=.FALSE.
  246.          ENDIF
  247.  
  248.          IF(CNDTN) THEN
  249.             NNDS=0
  250.          ELSE
  251. C       ... IPT4 = ici à la différence symétrique du MAPOIN et du support du CHPOINT ...
  252.             CALL ECROBJ('MAILLAGE',MAPOIN)
  253.             CALL ECROBJ('MAILLAGE',IPT3)
  254.             CALL PRDIFF
  255.             CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
  256.             IF(IERR.NE.0) GOTO 9999
  257.  
  258.             CALL ECROBJ('MAILLAGE',IPT4)
  259.             CALL NBNO
  260.             CALL LIRENT(NNDS,1,IRETOU)
  261.             IF(IERR.NE.0) GOTO 9999
  262.          ENDIF
  263.  
  264. C    ... IPT4 = intersection du MAPOIN et du support du CHPOINT ...
  265.          IF(NNDS.EQ.NBNMAP+NNSCHP) THEN
  266.             IPT4=0
  267.             NBNIN4=0
  268.          ELSE
  269.             CALL ECROBJ('MAILLAGE',MAPOIN)
  270.             CALL ECROBJ('MAILLAGE',IPT3)
  271.             CALL INTERS
  272.             CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
  273.             IF(IERR.NE.0) GOTO 9999
  274.  
  275. C       ... NBNIN4 = NomBre de Noeuds de l'INtersection ipt4 ...
  276.             CALL ECROBJ('MAILLAGE',IPT4)
  277.             CALL NBNO
  278.             CALL LIRENT(NBNIN4,1,IRETOU)
  279.             IF(IERR.NE.0) GOTO 9999
  280.          ENDIF
  281.  
  282.          IF(NBNIN4.EQ.0) THEN
  283. C       ... Quand NBNIN4=0 -> cas No 1 ...
  284.             SORCHP=.FALSE.
  285.             CALL ERREUR(-297)
  286.             CALL ERREUR(-296)
  287.          ELSE IF(NBNIN4.EQ.NBNMAP) THEN
  288. C       ... Si NBNIN4=NBNMAP (cas 2), il faut réduire le CHPOINT sur le maillage ...
  289.             CALL REDUIR(MCHPOI,MAPOIN,IRETOU)
  290.             IF(IRETOU.EQ.0) THEN
  291.                GOTO 9999
  292.             ELSE
  293.                ICHPOI(ICH)=IRETOU
  294.             ENDIF
  295.          ELSE IF (NBNIN4.EQ.NNSCHP) THEN
  296. C       ... Cas No 4 - le support du CHPOINT est entièrement contenu dans le
  297. C           maillage, donc on ne fait rien ...
  298.          ELSE
  299. C       ... Sinon, c'est le cas 3, il faut donc "aggrandir" le CHPOINT,
  300. C           en fait on va le réduire sur l'intersection IPT4, ceci pour
  301. C           éliminer les composantes dont le support est en dehors du maillage ...
  302.             CALL REDUIR(MCHPOI,IPT4,IRETOU)
  303.             IF(IRETOU.EQ.0) THEN
  304.                GOTO 9999
  305.             ELSE
  306.                 ICHPOI(ICH)=IRETOU
  307.             ENDIF
  308.          ENDIF
  309.  
  310.  20   CONTINUE
  311.       ENDIF
  312.  
  313.  
  314. C ... Puisqu'on ne sort que certains noeuds il faut transformer les
  315. C     connectivités, pour ceci on se servira du SEGMENT IEQUIV ...
  316.  
  317. C ... Recherche des numéros maxi et mini des noeuds dont on a besoin ...
  318.  
  319.       SEGACT MAPOIN
  320.       NBELEM=MAPOIN.NUM(/2)
  321.       NBNN=MAPOIN.NUM(/1)
  322.       IF(NBELEM.EQ.NBNMAP) THEN
  323.  
  324.          IF(NBNN.NE.1) GOTO 9999
  325.          IPTMIN=MAPOIN.NUM(1,1)
  326.          IPTMAX=MAPOIN.NUM(1,1)
  327.          DO 1500 I=1,NBELEM
  328.             IF(MAPOIN.NUM(1,I).LT.IPTMIN) IPTMIN=MAPOIN.NUM(1,I)
  329.             IF(MAPOIN.NUM(1,I).GT.IPTMAX) IPTMAX=MAPOIN.NUM(1,I)
  330.  1500    CONTINUE
  331.  
  332.       ELSE IF(NBELEM.EQ.0) THEN
  333.  
  334.          NBSOUS=MAPOIN.LISOUS(/1)
  335.          DO 1505 I=1,NBSOUS
  336.             IPT5=LISOUS(I)
  337.             SEGACT IPT5
  338.             NBNTMP=IPT5.NUM(/1)
  339.             NBETMP=IPT5.NUM(/2)
  340.             IF(NBNTMP.NE.1) GOTO 9999
  341.             IF(I.EQ.1) THEN
  342.                IPTMIN=IPT5.NUM(1,1)
  343.                IPTMAX=IPT5.NUM(1,1)
  344.             ENDIF
  345.             DO 1506 J=1,NBETMP
  346.                IF(IPT5.NUM(1,J).LT.IPTMIN) IPTMIN=IPT5.NUM(1,J)
  347.                IF(IPT5.NUM(1,J).GT.IPTMAX) IPTMAX=IPT5.NUM(1,J)
  348.  1506       CONTINUE
  349.  1505    CONTINUE
  350.  
  351.       ENDIF
  352.  
  353. C ... Initialisation du segment IEQUIV ...
  354.  
  355.       IECART=IPTMAX-IPTMIN+1
  356.       SEGINI IEQUIV
  357. C ... et son remplissage ...
  358.  
  359.       IF(NBELEM.EQ.NBNMAP) THEN
  360.  
  361.          DO 1510 I=1,NBELEM
  362.             LEQUIV(MAPOIN.NUM(1,I)-IPTMIN+1)=I
  363.  1510    CONTINUE
  364.  
  365.       ELSE IF(NBELEM.EQ.0) THEN
  366.  
  367.          NBSOUS=MAPOIN.LISOUS(/1)
  368.          K=0
  369.          DO 1515 I=1,NBSOUS
  370.             IPT5=LISOUS(I)
  371.             SEGACT IPT5
  372.             NBNTMP=IPT5.NUM(/1)
  373.             NBETMP=IPT5.NUM(/2)
  374.             IF(NBNTMP.NE.1) GOTO 9999
  375.             DO 1516 J=1,NBETMP
  376.                K=K+1
  377. C          ... Ici je suppose que chaque point n'est représenté qu'une
  378. C              seule fois dans MAPOIN. En conséquence, dans la ligne en dessous
  379. C              je n'ai pas mis de test si LEQUIV(IPT5.NUM(1,J)-IPTMIN+1) est
  380. C              différent de zéro ...
  381.                LEQUIV(IPT5.NUM(1,J)-IPTMIN+1)=K
  382.  1516       CONTINUE
  383.  1515    CONTINUE
  384.  
  385.       ENDIF
  386.  
  387.  
  388. C ... Préparation de la première ligne du fichier, on connaît déjà
  389. C     les nombres de noeuds et d'éléments, il manque les nombres de composantes
  390. C     de tous les  CHPOINTs (s'ils sont présents) ...
  391.  
  392.       NBVAR=0
  393.       IF(SORCHP) THEN
  394.          DO 30 ICH=1,NBCHPO
  395.             MCHPOI=ICHPOI(ICH)
  397.             NBCOMP=-1
  398.             CALL QUEPOI(MCHPOI,MELEME,INDIC,NBCOMP,NOMTOT)
  399.             IF(IERR.NE.0) GOTO 9999
  400.             NBVAR=NBVAR+NBCOMP
  401.   30  CONTINUE
  402.  
  403. C ... Maintenant on va remplir des segments contenant toutes les valeurs
  404. C     des CHPOINTs en un seul morceau ...
  405.  
  406.       NBCCHP=NBVAR
  407.       kk= 0
  408.       SEGINI VALCHP
  409. cC .. Boucle sur tous les CHPOINTs
  410.       DO 40 ICH=1,NBCHPO
  411.             MCHPOI=ICHPOI(ICH)
  412.             CALL EXTR11(MCHPOI,NCCHPO)
  413.             SEGACT NCCHPO
  414.             NCC=NCCHPO.MOTS(/2)
  415.  
  416. C ... Remplissage des valeurs du CHPOINT ...
  417.  
  418.          DO 1700 I=1,NCC
  419.             DO 1700 J=1,NBNMAP
  420.                RVACHP(I+kk,J)=0.D0
  421.  1700    CONTINUE
  422.  
  423.          SEGACT MCHPOI
  424.          NSOUPO=IPCHP(/1)
  425. C    ... IDECNP = DECalage des Numéros de Points ...
  426. C inutile         IDECNP=0
  427. C    ... Boucle sur les sous-zones du CHPOINT dont chacune est définie par ...
  428.          DO 1710 I=1,NSOUPO
  429. C       ... un segment MSOUPO ...
  430. C !!
  431. CDEBUG           WRITE(IOIMP,*) 'Sous-zone No ',I
  432.             MSOUPO=IPCHP(I)
  433.             SEGACT MSOUPO
  434.             NC=NOHARM(/1)
  435. C       ... son support géométrique ...
  436.             IPT7=IGEOC
  437.       CALL NOMOBJ('MAILLAGE','MASUPCHP',IPT7)
  438.             CALL ECROBJ('MAILLAGE',IPT7)
  439.             CALL NBNO
  440.             CALL LIRENT(NPOSCH,1,IRETOU)
  441.             IF(IERR.NE.0) GOTO 9999
  442.             SEGACT IPT7
  443. CDEBUG           WRITE(IOIMP,*) '  -> ',NPOSCH,' noeuds'
  444. CDEBUG           WRITE(IOIMP,*) 'IPT7 : ITYPEL = ',IPT7.ITYPEL
  445. CDEBUG           WRITE(IOIMP,*) 'IPT7 : NBELEM = ',IPT7.NUM(/2)
  446. C       ... et ses valeurs ...
  447.             MPOVAL=IPOVAL
  448.             SEGACT MPOVAL
  449.             N=VPOCHA(/1)
  450.             IF(N.NE.NPOSCH) THEN
  451.                MOTERR(1:8)='CHPOINT '
  452.                CALL ERREUR(708)
  453.                GOTO 10000
  454.             ENDIF
  455. C       ... Boucle sur les composantes du CHPOINT ...
  456.             DO 1720 J=1,NC
  457. C          ... dont on cherche la place dans NCCHPO ...
  458.                MOCOMP=NOCOMP(J)
  459.                 DO 1730 K=1,NCC
  460.                    IF(NCCHPO.MOTS(K).EQ.MOCOMP) GOTO 1740
  461.  1730          CONTINUE
  462.  1740          CONTINUE
  463.  
  464. C          ... Maintenant K pointe le NOCOMP(J) dans NCCHPO ...
  465. CDEBUG          WRITE(IOIMP,*) 'Composante No',J,' correspond à K = ',K
  466. C          ... Maintenant il faut parcourir les noeuds du support du CHPOINT ...
  467. C          ... Si ce support est un maillage élémentaire, ceci est simple ...
  468.                IF(IPT7.NUM(/2).GT.0) THEN
  469. CDEBUG      WRITE(IOIMP,*) 'Support = Maillage élémentaire'
  470.                   DO 1750 L=1,N
  471. C                ... ça ne marchera pas dans le cas général, car l'ordre des n'est pas
  472. C                    forcément le meme dans le MAPOIN et dans le support du CHPOINT ...
  473. C                    RVACHP(K+kk,L+IDECNP)=VPOCHA(L,J) ...
  474. C                ... il faut chercher la position du noeud ...
  475.                      NNSCHP=IPT7.NUM(1,L)
  476.                      IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
  477.                         NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
  478.                      ELSE
  479.                         NNMAPO=0
  480.                      ENDIF
  481. CDEBUG      WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
  482.                      IF(NNMAPO.NE.0) RVACHP(K+kk,NNMAPO)=VPOCHA(L,J)
  483.  1750             CONTINUE
  484. C          ... Sinon on va s'amuser ...
  485.                ELSE
  486. CDEBUG      WRITE(IOIMP,*) 'Support = Maillage composé'
  487.                   L=0
  488.                   NBSOUS=IPT7.LISOUS(/1)
  489.                   DO 1765 M=1,NBSOUS
  490.                      IPT8=IPT7.LISOUS(M)
  491.                      SEGACT IPT8
  492.                      NBELEM=IPT8.NUM(/2)
  493. CDEBUG      WRITE(IOIMP,*) 'IPT8 : ITYPEL = ',IPT8.ITYPEL
  494. CDEBUG      WRITE(IOIMP,*) 'IPT8 : NBELEM = ',NBELEM
  495.                      DO 1770 MM=1,NBELEM
  496.                         L=L+1
  497.                         NNSCHP=IPT8.NUM(1,MM)
  498.                         IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
  499.                            NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
  500.                         ELSE
  501.                            NNMAPO=0
  502.                         ENDIF
  503. CDEBUG      WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
  504.                         IF(NNMAPO.NE.0) RVACHP(K+kk,NNMAPO)=VPOCHA(L,J)
  505.  1770                CONTINUE
  506.  1765             CONTINUE
  507.                ENDIF
  508.  1720       CONTINUE
  509. C inutile            IDECNP=IDECNP+NPOSCH
  510.  1710    CONTINUE
  511.       kk=kk+NCC
  512.       IF(kk.GT.NBCCHP) GOTO 9999
  513.  40   CONTINUE
  514.       ENDIF
  515.  
  516. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  517. C           ... Sortie au format FER ...
  518. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  519.  
  520. C ... On écrase un éventuel contenu du fichier No IOPER ...
  521.       IF(INOREW.EQ.0) THEN
  522.        REWIND IOPER
  523.  
  524. C ... On écrit le titre
  525.          CALL LENCHA(TITHED,LTH)
  526.          WRITE(IOPER,4001) TITHED(1:LTH)
  527.  
  528. C ... Ligne de tete ...
  529.        WRITE(IOPER,4000) NBNMAP,IDIM
  530.  
  531. C ... Les noeuds ...
  532.       SEGACT,MCOORD
  533.       DO 2000 I=1,NBNMAP
  534.          SEGACT MAPOIN
  535.          NUMNO=MAPOIN.NUM(1,I)
  536.          IF(IDIM.EQ.2) THEN
  537.             WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
  538.      &                          XCOOR((NUMNO-1)*(IDIM+1)+2)
  539.          ELSE
  540.             WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
  541.      &                          XCOOR((NUMNO-1)*(IDIM+1)+2),
  542.      &                          XCOOR((NUMNO-1)*(IDIM+1)+3)
  543.          ENDIF
  544.  2000 CONTINUE
  545.       SEGDES,MCOORD
  546.  
  547. C ... Le maillage ...
  548.       WRITE(IOPER,4000) NELMAI
  549.       IDECAL=0
  550.       IF(EXISEL) THEN
  551.          SEGACT MAELEM
  552.          NBELEM=MAELEM.NUM(/2)
  553.          IF(NBELEM.GT.0) THEN
  554.             CALL FERMEL(MAELEM,IDECAL,1,IEQUIV,IPTMIN)
  555.          ELSE
  556.             NBSOUS=MAELEM.LISOUS(/1)
  557.             DO 2100 I=1,NBSOUS
  558.                LESOUS=MAELEM.LISOUS(I)
  559.                CALL FERMEL(LESOUS,IDECAL,I,IEQUIV,IPTMIN)
  560.  2100       CONTINUE
  561.          ENDIF
  562.       ENDIF
  563.  
  564.       ENDIF
  565.  
  566. C ... Les CHPOINTs ...
  567.       IF(SORCHP) THEN
  568.  
  569. C    ... On commence par les noms des composantes ...
  570.  
  571. C        Il faut récupérer les noms des variables
  572.          JGN=LOCOMP
  573.          JGM=NBVAR
  574.          JCPT=1
  575.          SEGINI MLMOTS
  576.          DO 60 INBCH=1,NBCHPO
  577.             MCHPOI=ICHPOI(INBCH)
  578.             SEGACT MCHPOI
  579.             MSOUPO=IPCHP(1)
  580.             SEGACT MSOUPO
  581.             NC=NOCOMP(/2)
  582.             DO 602 INC=1,NC
  583.                MOTS(JCPT)(1:1)=' '
  584.                LNC=LEN(NOCOMP(INC))
  585.                 DO 604 ILNC=1,LNC
  586.                   MOTS(JCPT)(ILNC+1:ILNC+1)=NOCOMP(INC)(ILNC:ILNC)
  587.  604           CONTINUE
  588.                MOTS(JCPT)(LNC+2:LNC+2)=' '
  589.                JCPT=JCPT+1
  590.  602        CONTINUE
  591.  60      CONTINUE
  592.  
  593. C ... Pour tracer les déformées, FERVIEW utilise les 3
  594. C ... premiers champs, il faut donc que se soient UX, UY, UZ
  595.  
  596.                  WRITE(NUX,'(A4)') ' UX '
  597.                  WRITE(NUY,'(A4)') ' UY '
  598.                  WRITE(NUZ,'(A4)') ' UZ '
  599.  
  600. C ... Boucles pour trouver les No de UX UY UZ respectivement
  601.  
  602.                 NBVALV=NBVAR
  603.                 SEGINI VALV
  604.  
  605.                 I=1
  606.                 DO 5030 J=1,NBVAR
  607.                 IF (MOTS(J).EQ.NUX)  THEN
  608.                 IVALV(I) = J
  609.                 I=I+1
  610.                 ENDIF
  611.  5030           CONTINUE
  612.  
  613.                 DO 5040 J=1,NBVAR
  614.                 IF(MOTS(J).EQ.NUY) THEN
  615.                 IVALV(I) = J
  616.                 I=I+1
  617.                 ENDIF
  618.  5040           CONTINUE
  619.  
  620.  
  621.                 DO 5050 J=1,NBVAR
  622.                 IF(MOTS(J).EQ.NUZ) THEN
  623.                 IVALV(I) = J
  624.                 I=I+1
  625.                 ENDIF
  626.  5050           CONTINUE
  627.  
  628.  
  629.               DO 5070 J=1,NBVAR
  630.               IF((MOTS(J).NE.NUZ).AND.(MOTS(J).NE.NUY)
  631.      &       .AND.(MOTS(J).NE.NUX)) THEN
  632.               IVALV(I) = J
  633.               I=I+1
  634.               ENDIF
  635.  5070          CONTINUE
  636.  
  637.  
  638. C ... IVALV(1,2,3 ...) contient respectivement les places de UX UY UZ ...
  639.  
  640. CDEBUG         DO 5000 J=1,NBVAR
  641. CDEBUG         WRITE(6,*) 'MOTS(J) =',MOTS(J)
  642. CDEBUG         WRITE(6,*) 'MOTS(IVALV(J))=',MOTS(IVALV(J))
  643. CDEBUG 5000     CONTINUE
  644.  
  645.        IF(INOREW.EQ.0) THEN
  646.           WRITE(IOPER,4030) NBCCHP, ((MOTS(IVALV(I))),I=1,NBVAR)
  647.        SEGSUP MLMOTS
  648.        ENDIF
  649.  
  650.        SEGSUP NCCHPO
  651.  
  652. C ... INFO SUR LE TPS
  653.  
  654.          WRITE(IOPER,4020)NBSUIT,VALTEM
  655.  
  656. C    ... Et ensuite leurs valeurs ...
  657.          DO 2200 I=1,NBNMAP
  658.             WRITE(IOPER,4050) I,(RVACHP((IVALV(K)),I),K=1,NBVAR)
  659.  2200    CONTINUE
  660.          SEGSUP VALCHP
  661.          SEGSUP VALV
  662.       ENDIF
  663.  
  664.  
  665. C ... Le ménage ...
  666.  
  667.       SEGSUP IEQUIV
  668.       SEGSUP MLCHPO
  669. C ... Il n'y a pas de champ global, donc ...
  670.  
  671.       RETURN
  672.  
  673. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  674. C  ... Fin de la partie où tout se passe bien ...
  675. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  676.  
  677.  9996 CONTINUE
  678.       WRITE(IOIMP,*)'Pas d''objet de type MAILLAGE spécifié'
  679.       GOTO 9999
  680.  
  681.  9997 CONTINUE
  682.       WRITE(IOIMP,*)'Pour l''instant, chaque enregistrement doit'
  683.       WRITE(IOIMP,*)'être associé à un instant précis (mot clé TEMP)'
  684.       GOTO 9999
  685.  
  686.  9999 CONTINUE
  687.        WRITE(IOIMP,*)'An error was detected in subroutine sorfer'
  688.       CALL ERREUR(223)
  689.  
  690. 10000 CONTINUE
  691.       IF(NCCHPO.NE.0) THEN
  692.          SEGSUP NCCHPO
  693.       ENDIF
  694.       IF(NCMCHA.NE.0) THEN
  695.          SEGSUP NCMCHA
  696.       ENDIF
  697.       IF(VALCHP.NE.0) THEN
  698.          SEGSUP VALCHP
  699.       ENDIF
  700.  
  701.       IF(IEQUIV.NE.0) THEN
  702.          SEGSUP IEQUIV
  703.       ENDIF
  704.  
  705.       RETURN
  706.  
  707.  4000 FORMAT(2I6)
  708.  4001 FORMAT(A)
  709.  4010 FORMAT(I5,3(1X,1P,1E14.7))
  710.  4015 FORMAT (99(A,1X))
  711.  4020 FORMAT(I6,E14.7)
  712.  4030 FORMAT(I5,2X, 99A)
  713.  4050 FORMAT(I6,12(1X,1P,E14.7))
  714.       END
  715.  
  716.  
  717.  
  718.  
  719.  
  720.  

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