Télécharger la plaquette Cast3M


fr en

Télécharger wrmtik.eso

Retour à la liste

Numérotation des lignes : 

wrmtik

  1. C WRMTIK    SOURCE    PV        20/09/26    21:20:17     10724          
  2.       SUBROUTINE WRMTIK(IFSAU,ITLACC,IMAX1,IFORM,IDEB)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. C***********************************************************************
  6. C NOM         : WRMTIK
  7. C DESCRIPTION : Ecriture des objets de type MATRIK sur le
  8. C               fichier IFSAU
  9. C               (appelé par wrpil.eso)
  10. C
  11. C LANGAGE     : ESOPE
  12. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  13. C               mél : gounand@semt2.smts.cea.fr
  14. C***********************************************************************
  15. C APPELES (E/S)    : ECDIFE (ecriture d'un tableau d'entiers)
  16. C                    ECDIFR (ecriture d'un tableau de REAL*8)
  17. C                    ECDIFM (ecriture d'un tableau de CHARACTER*4)
  18. C***********************************************************************
  19. C SYNTAXE GIBIANE    : SAUV
  20. C ENTREES            : IFSAU, numéro du fichier en écriture
  21. C                      IDEB, IMAX1, indice de début et de fin
  22. C                      de la pile des objets MATRIK (ITLACC)
  23. C                      à écrire.
  24. C                      IFORM, le fichier a ecrire est formaté ou
  25. C                             non.
  26. C***********************************************************************
  27. C VERSION    : v1, 15/07/98, version initiale
  28. C HISTORIQUE : v1, 15/07/98, création
  29. C HISTORIQUE :
  30. C HISTORIQUE :
  31. C***********************************************************************
  32. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  33. C en cas de modification de ce sous-programme afin de faciliter
  34. C la maintenance !
  35. C***********************************************************************
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  40. -INC TMCOLAC
  41.       SEGMENT/ITBBM1/( ITABM1(NM))
  42. C
  43.       INTEGER NDTAB
  44.       INTEGER IEL,I,J,K,L
  45.       INTEGER ILENA(11)
  46.       INTEGER IV1,IV2,IV3,IV4
  47. C======================================================================
  48. *
  49. * Executable statements
  50. *
  51. C
  52. C ... BOUCLE SUR LES MATRIK DE LA PILE
  53.       NM=0
  54.       SEGINI ITBBM1
  55.       DO 1 IEL=IDEB,IMAX1
  56.          MATRIK=ITLAC(IEL)
  57.          IF (MATRIK.EQ.0) THEN
  58.             WRITE(IOIMP,*) 'Failing to save a nil pointer'
  59.             WRITE(IOIMP,*) 'MATRIK type object...'
  60.             GOTO 9999
  61.          ENDIF
  62. C.... On initialise des piles d'objets non connus de CASTEM
  63. C     MINC, PMORS, IZA, IDMAT
  64. C     (Pb : des entiers distincts (par ex. KISPGP, KISPGT)
  65. C      peuvent etre egaux (i.e. pointer sur le meme objet)
  66. C      On ne veut pas sauvegarder l'objet deux fois...)
  67.          SEGINI ITLAC1
  68.          SEGINI ITLAC2
  69.          SEGINI ITLAC3
  70.          SEGINI ITLAC4
  71. C     Sauvegarde du chapeau
  72. C       Dimensions
  73.          SEGACT MATRIK
  74.          NRIGE =IRIGEL(/1)
  75.          NMATRI=IRIGEL(/2)
  76.          NKID=KIDMAT(/1)
  77.          NKMT=KKMMT(/1)
  78.          ILENA(1)=NRIGE
  79.          ILENA(2)=NMATRI
  80.          ILENA(3)=NKID
  81.          ILENA(4)=NKMT
  82.          NDTAB=4
  83.          CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  84. C       Rigidités élémentaires
  85.          NDTAB = NRIGE * NMATRI
  86.          CALL ECDIFE(IFSAU,NDTAB,IRIGEL,IFORM)
  87. C       Matrice assemblée
  88.          ILENA( 1)=KSYM
  89.          ILENA( 2)=KMINC
  90.          ILENA( 3)=KMINCP
  91.          ILENA( 4)=KMINCD
  92.          ILENA( 5)=KIZM
  93.          ILENA( 6)=KISPGT
  94.          ILENA( 7)=KISPGP
  95.          ILENA( 8)=KISPGD
  96.          ILENA( 9)=KNTTT
  97.          ILENA(10)=KNTTP
  98.          ILENA(11)=KNTTD
  99.          NDTAB=11
  100.          CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  101.          NDTAB=NKID
  102.          CALL ECDIFE(IFSAU,NDTAB,KIDMAT,IFORM)
  103.          NDTAB=NKMT
  104.          CALL ECDIFE(IFSAU,NDTAB,KKMMT,IFORM)
  105. C     Sauvegarde des IMATRI
  106.          DO 11 I=1,NMATRI
  107.             IMATRI=IRIGEL(4,I)
  108.             IF (IMATRI.NE.0) THEN
  109.                SEGACT IMATRI
  110.                NBSOUS=LIZAFM(/1)
  111.                NBME=LIZAFM(/2)
  112.                ILENA(1)=NBSOUS
  113.                ILENA(2)=NBME
  114.                NDTAB=2
  115.                CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  116.                NM=4*NBME
  117.                SEGADJ ITBBM1
  118.                DO 111 J=1,NBME
  119.                   J4=(4*J)-3
  120.                   READ (LISPRI(J),FMT='(2A4)') ITABM1(J4),ITABM1(J4+1)
  121.                   READ (LISDUA(J),FMT='(2A4)') ITABM1(J4+2),ITABM1(J4+3)
  122.  111           CONTINUE
  123.                CALL ECDIFM(IFSAU,NM,ITABM1,IFORM)
  124.                NDTAB=NBSOUS*NBME
  125.                CALL ECDIFE(IFSAU,NDTAB,LIZAFM,IFORM)
  126.                ILENA(1)=KSPGP
  127.                ILENA(2)=KSPGD
  128.                NDTAB=2
  129.                CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  130. C        Sauvegarde des IZAFM
  131.                DO 112 K=1,NBME
  132.                   DO 1121 L=1,NBSOUS
  133.                      IZAFM=LIZAFM(L,K)
  134.                      IF (IZAFM.NE.0) THEN
  135.                         SEGACT IZAFM
  136.                         NBEL=AM(/1)
  137.                         NP  =AM(/2)
  138.                         MP  =AM(/3)
  139.                         ILENA(1)=NBEL
  140.                         ILENA(2)=NP
  141.                         ILENA(3)=MP
  142.                         NDTAB=3
  143.                         CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  144.                         NDTAB=NBEL*NP*MP
  145.                         CALL ECDIFR(IFSAU,NDTAB,AM,IFORM)
  146.                         SEGDES IZAFM
  147.                      ENDIF
  148.  1121             CONTINUE
  149.  112           CONTINUE
  150.                SEGDES IMATRI
  151.             ENDIF
  152.  11      CONTINUE
  153. C     Sauvegarde des MINC
  154.          IV1=KMINC
  155.          IF (IV1.NE.0) THEN
  156.             CALL AJOUN2(ITLAC1,IV1)
  157.          ENDIF
  158.          JMINC=IV1
  159.          IV1=KMINCP
  160.          IF (IV1.NE.0) THEN
  161.             CALL AJOUN2(ITLAC1,IV1)
  162.          ENDIF
  163.          JMINCP=IV1
  164.          IV1=KMINCD
  165.          IF (IV1.NE.0) THEN
  166.             CALL AJOUN2(ITLAC1,IV1)
  167.          ENDIF
  168.          JMINCD=IV1
  169.          NBMINC=MAX(JMINC,JMINCP,JMINCD)
  170.          ILENA(1)=NBMINC
  171.          ILENA(2)=JMINC
  172.          ILENA(3)=JMINCP
  173.          ILENA(4)=JMINCD
  174.          NDTAB=4
  175.          CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  176.          DO 12 I=1,NBMINC
  177.             MINC=ITLAC1.ITLAC(I)
  178.             SEGACT MINC
  179.             NPT=MPOS(/1)
  180.             NBI=MPOS(/2)-1
  181.             ILENA(1)=NPT
  182.             ILENA(2)=NBI
  183.             NDTAB=2
  184.             CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  185.             NM=2*NBI
  186.             SEGADJ ITBBM1
  187.             DO 121 J=1,NBI
  188.                J2=(2*J)-1
  189.                READ (LISINC(J),FMT='(2A4)') ITABM1(J2),ITABM1(J2+1)
  190.  121        CONTINUE
  191.             CALL ECDIFM(IFSAU,NM,ITABM1,IFORM)
  192.             NDTAB=NPT+1
  193.             CALL ECDIFE(IFSAU,NDTAB,NPOS,IFORM)
  194.             NDTAB=NPT*(NBI+1)
  195.             CALL ECDIFE(IFSAU,NDTAB,MPOS,IFORM)
  196.             SEGDES MINC
  197.  12      CONTINUE
  198. C     Sauvegarde des PMORS
  199.          IV2=KIDMAT(4)
  200.          IF (IV2.NE.0) THEN
  201.             CALL AJOUN2(ITLAC2,IV2)
  202.          ENDIF
  203.          JMORS=IV2
  204.          IV2=KIDMAT(6)
  205.          IF (IV2.NE.0) THEN
  206.             CALL AJOUN2(ITLAC2,IV2)
  207.          ENDIF
  208.          JMRST=IV2
  209.          NBMORS=MAX(JMORS,JMRST)
  210.          ILENA(1)=NBMORS
  211.          ILENA(2)=JMORS
  212.          ILENA(3)=JMRST
  213.          NDTAB=3
  214.          CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  215.          DO 13 I=1,NBMORS
  216.             PMORS=ITLAC2.ITLAC(I)
  217.             SEGACT PMORS
  218.             NTT=IA(/1)-1
  219.             NJA=JA(/1)
  220.             ILENA(1)=NTT
  221.             ILENA(2)=NJA
  222.             NDTAB=2
  223.             CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  224.             NDTAB=NTT+1
  225.             CALL ECDIFE(IFSAU,NDTAB,IA,IFORM)
  226.             NDTAB=NJA
  227.             CALL ECDIFE(IFSAU,NDTAB,JA,IFORM)
  228.             SEGDES PMORS
  229.  13      CONTINUE
  230. C     Sauvegarde des IDMAT (faite avant les IZA
  231. C     car IDIAG pointe sur un IZA)
  232.          IV4=KIDMAT(1)
  233.          IF (IV4.NE.0) THEN
  234.             CALL AJOUN2(ITLAC4,IV4)
  235.          ENDIF
  236.          JDMATP=IV4
  237.          IV4=KIDMAT(2)
  238.          IF (IV4.NE.0) THEN
  239.             CALL AJOUN2(ITLAC4,IV4)
  240.          ENDIF
  241.          JDMATD=IV4
  242.          NBIDMA=MAX(JDMATP,JDMATD)
  243.          ILENA(1)=NBIDMA
  244.          ILENA(2)=JDMATP
  245.          ILENA(3)=JDMATD
  246.          NDTAB=3
  247.          CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  248. C     Sauvegarde des IZA
  249.          IV3=KIDMAT(3)
  250.          IF (IV3.NE.0) THEN
  251.             CALL AJOUN2(ITLAC3,IV3)
  252.          ENDIF
  253.          JS2B=IV3
  254.          IV3=KIDMAT(5)
  255.          IF (IV3.NE.0) THEN
  256.             CALL AJOUN2(ITLAC3,IV3)
  257.          ENDIF
  258.          JISA=IV3
  259.          IV3=KIDMAT(7)
  260.          IF (IV3.NE.0) THEN
  261.             CALL AJOUN2(ITLAC3,IV3)
  262.          ENDIF
  263.          JIST=IV3
  264.          IV3=KKMMT(4)
  265.          IF (IV3.NE.0) THEN
  266.             CALL AJOUN2(ITLAC3,IV3)
  267.          ENDIF
  268.          JZDU=IV3
  269.          IV3=KKMMT(5)
  270.          IF (IV3.NE.0) THEN
  271.             CALL AJOUN2(ITLAC3,IV3)
  272.          ENDIF
  273.          JZDP=IV3
  274.          IV3=KKMMT(6)
  275.          IF (IV3.NE.0) THEN
  276.             CALL AJOUN2(ITLAC3,IV3)
  277.          ENDIF
  278.          JZFU=IV3
  279.          IV3=KKMMT(7)
  280.          IF (IV3.NE.0) THEN
  281.             CALL AJOUN2(ITLAC3,IV3)
  282.          ENDIF
  283.          JZFP=IV3
  284.          NBIZA=MAX(JS2B,JISA,JIST,JZDU,JZDP,JZFU,JZFP)
  285. C     On sauvegarde les IZA contenus dans les IDMAT
  286.          DO 16 I=1,NBIDMA
  287.             IDMAT=ITLAC4.ITLAC(I)
  288.             SEGACT IDMAT*MOD
  289.             NBLK=IDESCL(/1)
  290. C       IDIAG
  291.             IV3=IDIAG
  292.             IF (IV3.NE.0) THEN
  293.                CALL AJOUN2(ITLAC3,IV3)
  294.                NBIZA=MAX(NBIZA,IV3)
  295.             ENDIF
  296.             IDIAG=IV3
  297. C       IDESCL
  298.             DO 161 J=1,NBLK
  299.                IV3=IDESCL(J)
  300.                IF (IV3.NE.0) THEN
  301.                   CALL AJOUN2(ITLAC3,IV3)
  302.                   NBIZA=MAX(NBIZA,IV3)
  303.                ENDIF
  304.                IDESCL(J)=IV3
  305.  161        CONTINUE
  306. C       IDESCU
  307.             DO 162 J=1,NBLK
  308.                IV3=IDESCU(J)
  309.                IF (IV3.NE.0) THEN
  310.                   CALL AJOUN2(ITLAC3,IV3)
  311.                   NBIZA=MAX(NBIZA,IV3)
  312.                ENDIF
  313.                IDESCU(J)=IV3
  314.  162        CONTINUE
  315.             SEGDES IDMAT
  316.  16      CONTINUE
  317.          DO 15 I=1,NBIDMA
  318.             IDMAT=ITLAC4.ITLAC(I)
  319.             SEGACT IDMAT
  320.             NTT =KZA(/1)
  321.             NPT =NUAN(/1)
  322.             NBLK=IDESCL(/1)
  323.             ILENA(1)=NTT
  324.             ILENA(2)=NPT
  325.             ILENA(3)=NBLK
  326.             ILENA(4)=IDIAG
  327.             NDTAB=4
  328.             CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  329.             NDTAB=NTT
  330.             CALL ECDIFE(IFSAU,NDTAB,KZA,IFORM)
  331.             NDTAB=2*NTT
  332.             CALL ECDIFE(IFSAU,NDTAB,NUIA,IFORM)
  333.             NDTAB=NPT
  334.             CALL ECDIFE(IFSAU,NDTAB,NUAN,IFORM)
  335.             NDTAB=NPT
  336.             CALL ECDIFE(IFSAU,NDTAB,NUNA,IFORM)
  337.             NDTAB=NBLK
  338.             CALL ECDIFE(IFSAU,NDTAB,IDESCL,IFORM)
  339.             NDTAB=NBLK
  340.             CALL ECDIFE(IFSAU,NDTAB,IDESCU,IFORM)
  341.             NDTAB=NBLK+1
  342.             CALL ECDIFE(IFSAU,NDTAB,NLDBLK,IFORM)
  343.             SEGDES IDMAT
  344.  15      CONTINUE
  345.          ILENA( 1)=NBIZA
  346.          ILENA( 2)=JS2B
  347.          ILENA( 3)=JISA
  348.          ILENA( 4)=JIST
  349.          ILENA( 5)=JZDU
  350.          ILENA( 6)=JZDP
  351.          ILENA( 7)=JZFU
  352.          ILENA( 8)=JZFP
  353.          NDTAB=8
  354.          CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  355.          DO 14 I=1,NBIZA
  356.             IZA=ITLAC3.ITLAC(I)
  357.             SEGACT IZA
  358.             NBVA=A(/1)
  359.             ILENA(1)=NBVA
  360.             NDTAB=1
  361.             CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM)
  362.             NDTAB=NBVA
  363.             CALL ECDIFR(IFSAU,NDTAB,A,IFORM)
  364.             SEGDES IZA
  365.  14      CONTINUE
  366. C    Restauration des pointeurs des IZA dans IDMAT
  367.          DO 17 I=1,NBIDMA
  368.             IDMAT=ITLAC4.ITLAC(I)
  369.             SEGACT IDMAT*MOD
  370.             NBLK=IDESCL(/1)
  371. C       IDIAG
  372.             IV3=IDIAG
  373.             IF (IV3.NE.0) IDIAG=ITLAC3.ITLAC(IV3)
  374. C       IDESCL
  375.             DO 171 J=1,NBLK
  376.                IV3=IDESCL(J)
  377.                IF (IV3.NE.0) IDESCL(J)=ITLAC3.ITLAC(IV3)
  378.  171        CONTINUE
  379. C       IDESCU
  380.             DO 172 J=1,NBLK
  381.                IV3=IDESCU(J)
  382.                IF (IV3.NE.0) IDESCU(J)=ITLAC3.ITLAC(IV3)
  383.  172        CONTINUE
  384.             SEGDES IDMAT
  385.  17      CONTINUE
  386.          SEGDES MATRIK
  387.          SEGSUP ITLAC4
  388.          SEGSUP ITLAC3
  389.          SEGSUP ITLAC2
  390.          SEGSUP ITLAC1
  391.  1    CONTINUE
  392.       SEGSUP ITBBM1
  393. *
  394. * Normal termination
  395. *
  396.       RETURN
  397. *
  398. * Format handling
  399. *
  400. *
  401. * Error handling
  402. *
  403.  9999 CONTINUE
  404.       WRITE(IOIMP,*) 'An error was detected in subroutine wrmtik'
  405.       RETURN
  406. *
  407. * End of subroutine WRMTIK
  408. *
  409.       END
  410.  
  411.  
  412.  
  413.  
  414.  
  415.  
  416.  
  417.  
  418.  
  419.  
  420.  
  421.  
  422.  
  423.  
  424.  
  425.  

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