Télécharger la plaquette Cast3M


fr en

Télécharger sortir.eso

Retour à la liste

Numérotation des lignes : 

sortir

  1. C SORTIR    SOURCE    PV        22/01/11    21:16:33     11258          
  2. C  SORTIE DE GIBI
  3. C  CE SOUS PROGRAMME PREPARE LE FICHIER DE SORTIE DE GIBI
  4. C  IL COMMENCE PAR EFFACER LES ENREGISTREMENTS DE MEME NOM
  5. C  DANS LE FICHIER DE COMMUNICATION  (A FAIRE)
  6. C  PUIS ECRIT UN ENREGISTREMENT (IMAGE DE CARTES) DONT LE
  7. C  NOM EST LE NOM D L'OBJET A PERFORER
  8. C
  9.       SUBROUTINE SORTIR(MELEME)
  10.       IMPLICIT INTEGER(I-N)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMELEME
  15. -INC CCGEOME
  16. -INC SMCOORD
  17. -INC TMLNOMS
  18.       SEGMENT JSGTR(0)
  19.       SEGMENT CSGT
  20.          CHARACTER*8 CSGTR(0)
  21.       ENDSEGMENT
  22.       SEGMENT ISGT
  23.          INTEGER ISGTR(0)
  24.       ENDSEGMENT
  25.       SEGMENT ILIST(ILL)
  26.       SEGMENT ITLAC(0)
  27.       POINTEUR ITLAC1.ITLAC
  28.       CHARACTER*8 NOBJ
  29.       CHARACTER*(8) CHAR
  30.       CHARACTER*4 BLAN
  31.  
  32.       DATA BLAN /'    '/
  33.  
  34.       SEGINI ITLAC
  35.       CALL QUENOM(NOBJ)
  36.       REWIND IOPER
  37.       SEGACT MELEME
  38.       CALL AJOU(ITLAC,MELEME)
  39.       IF(LISOUS(/1).NE.0) THEN
  40.          DO 2 I=1,LISOUS(/1)
  41.             IVAL=LISOUS(I)
  42.             CALL AJOU(ITLAC,IVAL)
  43.     2    CONTINUE
  44.       ENDIF
  45.       CALL TASSPO(ITLAC,icolac,ipt8,0,1)
  46.       segini,ITLAC1=ITLAC
  47.       CALL SUPPIL(ICOLAC,-1)
  48.       ITLAC=ITLAC1
  49.       segsup ipt8
  50.       IF (IERR.NE.0) RETURN
  51.  
  52. C LES POINTS SONT CLASSES AVEC EN TETE CEUX DE L'OBJET QUI NOUS
  53. C INTERESSE
  54. C RECHERCHONS LE PLUS GRAND POINT A SORTIR
  55. CG    Déja activé....
  56. CG      SEGACT MCOORD
  57.       SEGACT MELEME
  58.       IMAX=0
  59.       DO 5 IK=1,MAX(1,LISOUS(/1))
  60.          IF (LISOUS(/1).NE.0)THEN
  61.             IPT1=LISOUS(IK)
  62.             SEGACT IPT1
  63.          ELSE
  64.             IPT1=MELEME
  65.          ENDIF
  66.          DO 3 J=1,IPT1.NUM(/2)
  67.             DO 31 I=1,IPT1.NUM(/1)
  68.                IMAX=MAX(IMAX,IPT1.NUM(I,J))
  69.  31         CONTINUE
  70.    3     CONTINUE
  71.          IF (LISOUS(/1).NE.0) SEGDES IPT1
  72.    5  CONTINUE
  73.       SEGDES MELEME
  74. C  ICI IL FAUDRA RENUMEROTER D'APRES OBJET LES POINTS JUSQU'A IMAX
  75. C  ECRITURE DES ENREGISTREMENTS.POSITIONNEMENT A FAIRE QUAND ON SAURA
  76. C  COMMENT EST FAIT LE FICHIER
  77. C  PREMIER ENREGISTREMENT
  78.  
  79.       WRITE (IOPER,100) NOBJ,TITREE
  80.   100 FORMAT (A8,A72)
  81.  
  82. C  DEUXIEME ENREGISTREMENT
  83.       IF( IONIVE . EQ. 0 ) WRITE (IOPER,1010)
  84.       IF( IONIVE . EQ. 1 ) WRITE (IOPER,1011)
  85.       IF( IONIVE . GE. 2 ) WRITE (IOPER,1012)
  86.  1010 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 000  16/01/1983')
  87.  1011 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 001  01/09/1985')
  88.  1012 FORMAT('MAILLAGE PROVENANT DE GIBI NIVEAU 002  29/07/1987')
  89.  
  90. C  PARAMETRES DU MAILLAGE
  91.       WRITE (IOPER,102) IERMAX,IDIM,DENSIT
  92.  102  FORMAT('ERREUR',I4,' DIMENSION',I4,' DENSITE ',1PE12.5)
  93.  
  94. C  COORDONNEES (IDIM+DENS)
  95.        WRITE(IOPER,103) IMAX
  96.   103 FORMAT ('NOMBRE DE POINTS ',I8)
  97.        ILONG=(IDIM+1)*IMAX
  98.        WRITE (IOPER,104) (XCOOR(I),I=1,ILONG)
  99.  104  FORMAT (1P,6E12.5)
  100.  
  101. C CONSTRUCTION DE LA TABLE DES POINTS A PERFORER
  102.       SEGINI CSGT,ISGT
  103.       CALL REPERT('POINT   ',ITITI)
  104.       IF(ITITI.NE.0) THEN
  105.          CALL REPLIS('POINT   ',MLNOMS)
  106.          ICO=1
  107.          DO 11 I=1,ITITI
  108.             CALL LIROBJ('POINT   ',IP1,1,IRETOU)
  109.             IF(IERR.NE.0) RETURN
  110.             IF (IP1.EQ.0) GOTO 11
  111.             IF(IP1.GT.IMAX) GOTO 11
  112.             ISGTR(**)=IP1
  113.             CSGTR(**)=LINOMS(I)
  114.             ICO=ICO+3
  115.   11     CONTINUE
  116.          SEGSUP MLNOMS
  117.   12  ENDIF
  118.  
  119. C  POINTS NOMMES
  120.       ILONG=ISGTR(/1)
  121.       WRITE (IOPER,105) ILONG
  122.  105  FORMAT('NOMBRE DE POINTS NOMMES',I8)
  123.  
  124.       IF (ILONG.NE.0) THEN
  125.          WRITE (IOPER,106)(CSGTR(I),ISGTR(I),I=1,ILONG)
  126.  106     FORMAT (5(A8,I8))
  127.   50  ENDIF
  128.  
  129. C  LISTE DES OBJETS A PERFORER
  130.       SEGSUP ISGT,CSGT
  131.       SEGINI JSGTR
  132.       CALL QUIDAN(JSGTR,ITLAC,IMAX)
  133.       SEGSUP ITLAC
  134.  
  135. C  DANS JSGTR LISTE DES OBJETS A PERFORER
  136. C   ON LES PERFORE EN REMPLACANT LES REFERENCES AUX OBJETS POINTES
  137. C   ET EN METTANT LE TYPE DE L'ELEMENT EN CLAIR
  138.  
  139.       ILONG=JSGTR(/1)
  140.       WRITE (IOPER,107) ILONG
  141.  107  FORMAT('NOMBRE D''OBJETS ',I8)
  142.  
  143.       DO 20 I=1,ILONG
  144.          MELEME=JSGTR(I)
  145.          SEGACT MELEME*MOD
  146.          IF (IONIVE.LE.1) THEN
  147.             IF (ITYPEL.EQ.0) THEN
  148.        WRITE (IOPER,108) BLAN,LISOUS(/1),LISREF(/1),NUM(/1),NUM(/2)
  149.             ELSE
  150.        WRITE (IOPER,108) NOMS(ITYPEL),LISOUS(/1),LISREF(/1),NUM(/1),
  151.      #  NUM(/2)
  152.             ENDIF
  153.          ELSE
  154.             IF (ITYPEL.EQ.0) THEN
  155.        WRITE (IOPER,1108) BLAN,LISOUS(/1),LISREF(/1),NUM(/1),NUM(/2)
  156.             ELSE
  157.        WRITE (IOPER,1108) NOMS(ITYPEL),LISOUS(/1),LISREF(/1),NUM(/1),
  158.      #  NUM(/2)
  159.             ENDIF
  160.          ENDIF
  161.  108  FORMAT(A4,' SOUS OBJETS',I4,' REFERENCES',I4,' NB NOEUDS',I4,
  162.      # ' NB ELEM',I4)
  163. 1108  FORMAT(A4,' SOUS OBJETS',I4,' REFERENCES',I4,' NB NOEUDS',I4,
  164.      # ' NBELEM',I5)
  165.  
  166.          IF (LISOUS(/1).NE.0) THEN
  167.             ILL=LISOUS(/1)
  168.             SEGINI ILIST
  169.             DO 22 J=1,LISOUS(/1)
  170.                JOB=LISOUS(J)
  171.                DO 23 K=1,JSGTR(/1)
  172.                   IF (JOB.EQ.JSGTR(K)) GOTO 24
  173.   23           CONTINUE
  174.                CALL ERREUR(9)
  175.                RETURN
  176.   24           ILIST(J)=K
  177.   22        CONTINUE
  178.             WRITE (IOPER,109) (ILIST(L),L=1,ILL)
  179.  109        FORMAT (20I4)
  180.             SEGSUP ILIST
  181.   21     ENDIF
  182.  
  183.          IF (LISREF(/1).NE.0) THEN
  184.             ILL=LISREF(/1)
  185.             SEGINI ILIST
  186.             DO 26 J=1,ILL
  187.                JOB=LISREF(J)
  188.                DO 27 K=1,JSGTR(/1)
  189.                   IF (JOB.EQ.JSGTR(K)) GOTO 28
  190.   27           CONTINUE
  191.                CALL ERREUR(9)
  192.                RETURN
  193.   28           ILIST(J)=K
  194.   26        CONTINUE
  195.             WRITE (IOPER,110) (ILIST(L),L=1,ILL)
  196.  110        FORMAT(20I4)
  197.             SEGSUP ILIST
  198.   25     ENDIF
  199.  
  200.          NBNN=NUM(/1)
  201.          NBELEM=NUM(/2)
  202.          IF (NBNN*NBELEM.EQ.0) GOTO 30
  203.          IF (IONIVE.NE.0)   THEN
  204.             DO 1140 L1= 1,NBELEM
  205.                IF(ICOLOR(L1).EQ.0) ICOLOR(L1)=IDCOUL
  206.  1140       CONTINUE
  207.             WRITE (IOPER,114) (NCOUL(ICOLOR(L1)),L1=1,NBELEM)
  208.  114        FORMAT (16(1X,A4))
  209.          ENDIF
  210.          WRITE (IOPER,111) ((NUM(L1,L2),L1=1,NBNN),L2=1,NBELEM)
  211.  111     FORMAT (16I5)
  212.   30     CONTINUE
  213.          SEGDES MELEME
  214.   20  CONTINUE
  215.  
  216. C  IL NE RESTE PLUS QUE LA LISTE DES NOMS D'OBJETS A SORTIR
  217.  
  218.       ILL=JSGTR(/1)*3
  219.       SEGINI ILIST
  220.       ICO=0
  221.       CALL REPERT('MAILLAGE',ITITI)
  222.       CALL REPLIS('MAILLAGE',MLNOMS)
  223.       SEGACT MLNOMS
  224.       DO 40 I=1,ITITI
  225.          CALL LIROBJ('MAILLAGE',IOB,1,IRETOU)
  226.          IF(IERR.NE.0) RETURN
  227.          IF (IOB.EQ.0) GOTO 40
  228.          DO 41 J=1,JSGTR(/1)
  229.             IF (IOB.EQ.JSGTR(J)) GOTO 42
  230.   41     CONTINUE
  231.          GOTO 40
  232.   42     CONTINUE
  233.          IF (ICO+3.GT.ILIST(/1)) THEN
  234.             ILIST(**)=0
  235.             ILIST(**)=0
  236.             ILIST(**)=0
  237.   43     ENDIF
  238.          ICO=ICO+1
  239.          READ(LINOMS(I),FMT='(2A4)')ILIST(ICO),ILIST(ICO+1)
  240.          ICO=ICO+2
  241.          ILIST(ICO)=J
  242.   40  CONTINUE
  243.  
  244.       ILONG=ICO/3
  245.       WRITE (IOPER,112) ILONG
  246.  112  FORMAT('NOMBRE D''OBJETS NOMMES',I8)
  247.  
  248.       WRITE (IOPER,113) (ILIST(I),I=1,ICO)
  249.  113  FORMAT (5(2A4,I8))
  250.  
  251.       SEGSUP ILIST,JSGTR
  252.       RETURN
  253.       END
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  

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