Télécharger la plaquette Cast3M


fr en

Télécharger wrpil.eso

Retour à la liste

Numérotation des lignes : 

wrpil

  1. C WRPIL     SOURCE    OF166741  24/12/18    21:15:41     12092          
  2.  
  3. C=======================================================================
  4. C      BUT     : ECRITURE DES PILES SUR LE FICHIER IOSAU
  5. C      APPELE PAR SAUV
  6. C      APPELLE : WRPOIN NOMMEF SOPAPF ECDIFE ECDIFM ECDIFR SOSOLF
  7. C              : ECDES ECDIFP  JDANSI WRMAIL
  8. C      ECRIT PAR FARVACQUE   - REPRIS PAR LENA
  9. C
  10. C HISTORIQUE : ajout des objets de type MATRAK et MATRIK par
  11. C              GOUNAND (15/07/98)
  12. C              ajout des tableaux de noms d'inconnues primales et duales
  13. C              LNOMDD, LNOMDU gounand (06/11/2014)
  14. C
  15. C=======================================================================
  16. C  TABLEAU KCOLA: VOIR SIGNIFICATION DANS SOUS-PROGRAMME TYPFIL
  17. C=======================================================================
  18.       SUBROUTINE WRPIL(ICOLAC,IMAX,IFORM,LABEL,isilen)
  19.  
  20.       IMPLICIT INTEGER(I-N)
  21.       IMPLICIT REAL*8(A-H,O-Z)
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC CCREEL
  26. -INC CCNOYAU
  27. -INC CCGEOME
  28. -INC CCFXDR
  29. -INC CCHAMP
  30.  
  31. -INC SMELEME
  32. -INC SMBASEM
  33. -INC SMRIGID
  34. -INC SMCOORD
  35. -INC SMSTRUC
  36. -INC SMDEFOR
  37. -INC SMLREEL
  38. -INC SMLENTI
  39. -INC SMCHARG
  40. -INC SMEVOLL
  41. -INC SMELSTR
  42. -INC SMCLSTR
  43. -INC SMTEXTE
  44. -INC SMSUPER
  45. -INC SMVECTD
  46. -INC SMLMOTS
  47. -INC SMTABLE
  48. -INC SMLCHPO
  49. -INC SMINTE
  50. -INC SMLOBJE
  51.  
  52. -INC TMCOLAC
  53.  
  54.       SEGMENT/ITBBE1/( ITABE1(NN))
  55.       SEGMENT/ITBBE2/( ITABE2(NN))
  56.       segment itbbc2
  57.        character*4 itabc2(nn)
  58.       endsegment
  59.       SEGMENT/ITBBM1/( ITABM1(NM))
  60.       segment itbbc1
  61.        character*4 itabc1(nm)
  62.       endsegment
  63.       SEGMENT/ITBBM2/( ITABM2(NM2))
  64.       segment itbbc3
  65.        character*4 itabc3(nm2)
  66.       endsegment
  67.       SEGMENT/ITBBM3/( ITABM3(NM2))
  68.       segment itbbc4
  69.        character*4 itabc4(nm2)
  70.       endsegment
  71.       SEGMENT/ITBBM4/( ITABM4(NM2))
  72.       segment itbbc5
  73.        character*4 itabc5(nm2)
  74.       endsegment
  75.       SEGMENT/ITABR1/( TABR1(L)*D)
  76.       SEGMENT ITAMOT
  77.       CHARACTER*(NN) ITAMO
  78.       INTEGER ICOTA(NNN)
  79.       ENDSEGMENT
  80.       segment xmaaux
  81.        real*8 reaux(laux,nelrig)
  82.       endsegment
  83.  
  84.       CHARACTER*(8) ITYPE,ITYPO
  85.       CHARACTER*512 CHA1
  86.       CHARACTER*72 LABEL
  87.       REAL*8 XRA
  88.       LOGICAL LIRA
  89.       DIMENSION ILENA(30)
  90.       DIMENSION IPV(2)
  91.       real*4 densi4
  92.  
  93. C======================================================================
  94.       WRITE (IOIMP,19) IONIVE
  95.  19   FORMAT (//,' NIVEAU DU FICHIER DE SAUVEGARDE',I3)
  96.  
  97. *  verif ouverture du fichier de sauvegarde
  98.       if (iform.eq.2) then
  99.         if (ixdrw.eq.0) call erreur(-195)
  100.         if (ixdrw.eq.0) call erreur(558)
  101.         if (ierr.ne.0) return
  102.       endif
  103.  
  104.       ITBBE1=0
  105.       ITBBE2=0
  106.       ITBBM1=0
  107.       ITBBM2=0
  108.       ITBBM3=0
  109.       ITBBM4=0
  110.       ITABR1=0
  111.  
  112.       SEGACT ICOLAC
  113.       NITLAC=ICOLA(/1)
  114.       IF (IPSAUV.NE.0) GOTO 7654
  115.  
  116. C  **** TITRE ********************************************
  117. C
  118. C     IQUOI=3
  119. C     CALL ECDES (IOSAU,IQUOI,IFORM)
  120. C     CALL ECDIFM (IOSAU,18,TITREE,IFORM)
  121. C
  122. C  **** INFORMATIONS GENERALES  MAILLAGE *****************
  123. C  **** INFORMATIONS GENERALES A METTRE DANS LES COMMONS
  124. C
  125.       IQUOI=4
  126.       CALL ECDES (IOSAU,IQUOI,IFORM)
  127.       IF(IFORM.EQ.1) WRITE(IOSAU,701) IONIVE, IERMAX,IDIM
  128.       IF(IFORM.EQ.0) WRITE(IOSAU)     IONIVE, IERMAX,IDIM
  129.       if(iform.eq.2) then
  130.        ios=IXDRINT( ixdrw, IONIVE )
  131.        ios=IXDRINT( ixdrw, iermax )
  132.        ios=IXDRINT( ixdrw, idim   )
  133.        dimatt = dimatt + 4
  134.       endif
  135.  701  FORMAT(' NIVEAU',I4,' NIVEAU ERREUR',I4,' DIMENSION',I4)
  136.  
  137.       LCOMWR = -1
  138.       if (ionive.lt.23) goto 9001
  139. C     A partir du Niveau 23 :
  140. C     Ecriture de la longueur des Chaines de CARACTERES des composantes ('MCHAML','CHPOINT','LISTMOTS',etc.)
  141. C     Attention LOCOMP est un PARAMETER on ne peut pas l'envoyer a IXDRINT qui le reecrit en sortie pour controle
  142.       LCOMWR = MIN(LOCOMP,LOCHAI)
  143.       IF (IFORM.EQ.1) WRITE(IOSAU,700) LCOMWR
  144.       IF (IFORM.EQ.0) WRITE(IOSAU)     LCOMWR
  145.       if (iform.eq.2) then
  146.         ios    = IXDRINT( ixdrw, LCOMWR )
  147.         dimatt = dimatt + 2
  148.       endif
  149.  700  FORMAT(' TAILLE DES COMPOSANTES',I4)
  150.  9001 continue
  151.  
  152. C     Ecriture de la DENSITE
  153.       IF (IFORM.EQ.1)WRITE(IOSAU,702) DENSIT
  154.       IF (IFORM.EQ.0)WRITE(IOSAU) DENSIT
  155.       if (iform.eq.2) then
  156.         densi4 = densit
  157.         ios    = IXDRREAL( ixdrw, densi4 )
  158.         dimatt = dimatt + 2
  159.       endif
  160.  702  FORMAT(' DENSITE',E12.5)
  161. C
  162. C ***** INFORMATIONS GENERALES CASTEM2000 *****************
  163. C Depuis le niveau 6, N = 8 (avant 7)
  164.       IQUOI=7
  165.       CALL ECDES (IOSAU,IQUOI,IFORM)
  166.       N = 8
  167.       if (ionive.lt.6) N = 7
  168.       IF(IFORM.EQ.1)WRITE(IOSAU,703) N
  169.       IF(IFORM.EQ.0)WRITE(IOSAU) N
  170.       if (iform.eq.2) then
  171.         ios    = IXDRINT( ixdrw, n)
  172.         dimatt = dimatt + 2
  173.       endif
  174.  703  FORMAT(' NOMBRE INFO CASTEM2000',I4)
  175.  
  176. C  A partir du niveau 20, NSDPGE n'est plus utile...
  177.       izzz = 0
  178.       IF (IFORM.EQ.1) THEN
  179.         WRITE(IOSAU,704) IFOUR,NIFOUR,IFOMOD,ILGNI,IIMPI,IOSPI,ISOTYP
  180.         IF (IONIVE.GE.20) WRITE(IOSAU,707) izzz
  181.         if (IONIVE.ge.6.and.IONIVE.le.19) WRITE(IOSAU,706) izzz
  182.       ENDIF
  183.       IF (IFORM.EQ.0) WRITE(IOSAU) IFOUR,NIFOUR,IFOMOD,ILGNI,IIMPI,
  184.      &                             IOSPI,ISOTYP,izzz
  185.       if (iform.eq.2) then
  186.         ios    = IXDRINT( ixdrw, ifour )
  187.         ios    = IXDRINT( ixdrw, nifour)
  188.         ios    = IXDRINT( ixdrw, ifomod)
  189.         ios    = IXDRINT( ixdrw, ILGNI )
  190.         ios    = IXDRINT( ixdrw, iimpi )
  191.         ios    = IXDRINT( ixdrw, iospi )
  192.         ios    = IXDRINT( ixdrw, isotyp)
  193.         ios    = IXDRINT( ixdrw, izzz  )
  194.         dimatt = dimatt + 9
  195.       endif
  196.  704  FORMAT(' IFOUR',I4,' NIFOUR',I4,' IFOMOD',I4,' ILGNI',I4,
  197.      &       ' IIMPI',I4,' IOSPI' ,I4,' ISOTYP',I4)
  198.  706  FORMAT(' NSDPGE',I6)
  199.  707  FORMAT(' ------',I6)
  200.  
  201.  7654 CONTINUE
  202. C
  203. C ****** Noms des composantes primales et duales
  204. C        repris de l'écriture des LISTMOTS
  205. C        Ecriture depuis le niveau 19
  206.       IF (IONIVE.LT.19) GOTO 9019
  207.       IQUOI=8
  208.       CALL ECDES (IOSAU,IQUOI,IFORM)
  209. * Primal
  210.       ILENA(1) = LEN(NOMDD(1))
  211.       ILENA(2) = LNOMDD
  212.       ITOTO=2
  213.       CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  214.       NNA = ILENA(1)
  215.       NNN = 0
  216.       NN  = ILENA(1)*ILENA(2)
  217.       SEGINI ITAMOT
  218.       DO IMM=1,ILENA(2)
  219.         ITAMO((IMM-1)*NNA+1:IMM*NNA)=NOMDD(IMM)
  220.       ENDDO
  221.       CALL ECDIFC( IOSAU,ITAMO,IFORM)
  222.       SEGSUP ITAMOT
  223. * Dual
  224.       ILENA(1) = LEN(NOMDU(1))
  225.       ILENA(2) = LNOMDU
  226.       ITOTO = 2
  227.       CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  228.       NNA = ILENA(1)
  229.       NNN = 0
  230.       NN  = ILENA(1)*ILENA(2)
  231.       SEGINI ITAMOT
  232.       DO IMM=1,ILENA(2)
  233.         ITAMO((IMM-1)*NNA+1:IMM*NNA)=NOMDU(IMM)
  234.       ENDDO
  235.       CALL ECDIFC(IOSAU,ITAMO,IFORM)
  236.       SEGSUP ITAMOT
  237.  9019 CONTINUE
  238.  
  239. C=DEB= FORMULATION HHO = Sauvegarde Elements particuliers ==============
  240. C=     Ecriture a partir du niveau 26
  241.       IF (IONIVE.LT.26) GOTO 9026
  242.       IQUOI = 9
  243.       CALL ECDES(IOSAU,IQUOI,IFORM)
  244.       CALL HHOPIL(4,IOSAU,IFORM)
  245.       IF (IERR.NE.0) RETURN
  246.  9026 CONTINUE
  247. C=FIN= FORMULATION HHO =================================================
  248.  
  249. C  **** COORDONNEES + MELEME : APPEL DE MAILLA ********************
  250. C
  251. C      IF(IMAX.NE.0) CALL WRPOIN (IMAX,IFORM,ICOLAC)
  252. C
  253. C  **** BOUCLE SUR LES FILES DE SORTIE IFILE=1,NITLAC *************
  254. C
  255.       DO 1099 IFILE=1,NITLAC
  256. *pv on se sort pas le mmatri
  257.          if (ifile.eq.16) goto 1099
  258. *tc on ne sort pas les points
  259. *         if(ifile.eq.32) GOTO 1099
  260.          ITLACC=KCOLA(IFILE)
  261.          IMAX1=ITLAC(/1)
  262.          IF(IMAX1.EQ.0) GOTO 1099
  263.          IDEB=1
  264.          IF(IPSAUV.NE.0) IDEB=KCOLAC(IFILE)+1
  265.          IF(IMAX1.LT.IDEB.AND.IFILE.NE.32) GOTO 1099
  266.          ITYPE='        '
  267.          CALL TYPFIL(ITYPE,IFILE)
  268.  
  269.          IF (IFILE.NE.8.AND.IFILE.NE.36.AND. ISILEN.NE.1)
  270.      $     WRITE(IOIMP,801)IFILE,IMAX1,ITYPE
  271.  801     FORMAT(/,'  LA PILE NUMERO',I4,' CONTIENT',I8,' OBJET(S) ',A8)
  272. C
  273.          IP1=ICOLA(IFILE)
  274.          IF (IFILE.NE.8.AND.IFILE.NE.36)
  275.      $      CALL NOMMEF (IP1,IMAX1,IFILE,IFORM,IDEB,isilen)
  276.          GOTO(6001,6002,6003,6004,6005,6006,6007,6008,6009,6010,
  277.      &        6011,6012,6013,6014,6015,6016,6017,6018,6019,6020,
  278.      &        6021,6022,6023,6024,6025,6026,6027,6028,6029,6030,
  279.      &        6031,6032,6033,6034,6035,6036,6037,6038,6039,6040,
  280.      &        6041,6042,6043,6010,6045,6010,6010,6048,6049,6050,
  281.      &        6051), IFILE
  282.  1001    MOTERR(1:8)=ITYPE
  283.          CALL ERREUR(336)
  284.          GOTO 1099
  285. C     **************************MELEME *********************************
  286.  6001    CONTINUE
  287.          DO 1100 IEL=IDEB,IMAX1
  288.             MELEME=ITLAC(IEL)
  289.             CALL WRMAIL(MELEME,IOSAU,IRETOU,IFORM)
  290.  1100    CONTINUE
  291.          GOTO 1098
  292. C     **************************CHPOINT*********************************
  293.  6002    CONTINUE
  294.          CALL WRCHPO(IOSAU,ITLACC,IMAX1,IFORM,IDEB,LCOMWR)
  295.          GOTO 1098
  296. C     ***********************MRIGID*************************************
  297.  6003    CONTINUE
  298.          DO 1202 IEL=IDEB,IMAX1
  299.             MRIGID=ITLAC(IEL)
  300.             SEGACT MRIGID*mod
  301.             NRIGEL=IRIGEL(/2)
  302.             NRIGE =IRIGEL(/1)
  303.             NBGEOR=0
  304.             IF(IMGEO1.NE.0) THEN
  305.                IMGEOD=IMGEO1
  306.                SEGACT IMGEOD
  307.                NBGEOR=IMGEOR(/1)
  308.             ENDIF
  309. *pv      IF(ICHOLE.GE.0) THEN
  310. *pv         ICHOLX=0
  311. *pv      ELSE
  312. *pv         ICHOLX=-ICHOLE
  313. *pv      ENDIF
  314.             ICHOLX=0
  315.             ILENA(1)=NRIGEL
  316.             ILENA(2)=ICHOLX
  317.             ILENA(3)=NBGEOR
  318.             ILENA(4)=NRIGE
  319.             ILENA(5)=IFORIG
  320.             ITOTO=5
  321.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  322.  
  323.             ITOTO=2
  324.             if (ichar(mtymat(1:1)).eq.0) mtymat=' '
  325.             READ (MTYMAT,FMT='(2A4)') IPV
  326.             if (iform.ne.2) CALL ECDIFM (IOSAU,ITOTO,IPV,IFORM)
  327.             if (iform.eq.2) then
  328.              ios=IXDRSTRING( ixdrw, mtymat(1:8))
  329.              dimatt = dimatt + 2
  330.             endif
  331.  
  332.             NN=NRIGE*NRIGEL+NBGEOR +NRIGEL
  333.             SEGINI ITBBE1
  334.             NNN=0
  335.             DO 1203 IR=1,NRIGEL
  336.                DESCR=IRIGEL(3,IR)
  337.                SEGACT DESCR
  338.                xmatri=irigel(4,ir)
  339.                if (xmatri.gt.0) then
  340.                segact xmatri
  341.                nelrig=re(/3)
  342.                endif
  343.                NLIGRP=NOELEP(/1)
  344.                NLIGRD=NOELED(/1)
  345.                II=NRIGE*(IR-1)
  346.                DO 1204 NR=1,NRIGE
  347.                   IRR=II+NR
  348.                   ITABE1(IRR)=IRIGEL(NR,IR)
  349.  1204          CONTINUE
  350.                ITABE1(II+3)=NLIGRP
  351.                if (ionive.le.19) ITABE1(II+4)=nelrig
  352.                ITABE1(NRIGE*NRIGEL + NBGEOR + IR)=NLIGRD
  353.                NNN=NNN+NLIGRP + NLIGRD
  354.                SEGDES DESCR
  355.  1203       CONTINUE
  356.             IF(NBGEOR.NE.0) THEN
  357.                DO 1206 I=1,NBGEOR
  358.                   IVA=IMGEOR(I)
  359.                   ITABE1(NRIGE*NRIGEL+I)=IVA
  360.  1206          CONTINUE
  361.                SEGDES IMGEOD
  362.             ENDIF
  363.  1207       CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  364.  
  365.             NN=NNN
  366.             SEGADJ ITBBE1
  367.             NM=NNN
  368.             SEGINI ITBBM1,itbbc1
  369.             J=0
  370.             DO 1208 IR=1,NRIGEL
  371.                DESCR=IRIGEL(3,IR)
  372.                SEGACT DESCR
  373.                NLIGRP=NOELEP(/1)
  374.                NLIGRD=NOELED(/1)
  375.                DO 1205 I=1,NLIGRP
  376.                   J=J+1
  377.                   ITABE1(J)=NOELEP(I)
  378.                   READ (LISINC(I),FMT='(A4)') ITABM1(J)
  379.                   itabc1(j)=lisinc(i)
  380.  1205          CONTINUE
  381.                DO 1209 I=1,NLIGRD
  382.                   J=J+1
  383.                   ITABE1(J)=NOELED(I)
  384.                   READ (LISDUA(I),FMT='(A4)') ITABM1(J  )
  385.                   itabc1(j)=lisdua(i)
  386.  1209          CONTINUE
  387.                SEGDES DESCR
  388.  1208       CONTINUE
  389.             CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  390.             if (iform.ne.2) CALL ECDIFM(IOSAU,NM,ITABM1,IFORM)
  391.             if (iform.eq.2) then
  392.              ios=IXDRSTRING( ixdrw, itabc1(1)(1:nm*4))
  393.              dimatt = dimatt + nm
  394.             endif
  395.             SEGSUP ITBBE1,ITBBM1,itbbc1
  396.             CALL ECDIFR(IOSAU,NRIGEL,COERIG,IFORM)
  397.             if (ionive.le.19) then
  398.             do 1210 ir=1,nrigel
  399.               xmatri=irigel(4,ir)
  400.               segact xmatri
  401.               lval=re(/1)*re(/2)*re(/3)
  402.               CALL ECDIFR(IOSAU,lval,re,IFORM)
  403.               segdes xmatri
  404.  1210       continue
  405.             endif
  406.             SEGDES MRIGID
  407.  1202    CONTINUE
  408.          GOTO 1098
  409. C     ***************************        *******************************
  410.  6004    CONTINUE
  411.          GOTO 1098
  412. C     ***********************          *********************************
  413.  6005    CONTINUE
  414.          GOTO 1098
  415. C ********************************BLOQ STRUC
  416.  6006    CONTINUE
  417.          DO 60 IEL=IDEB,IMAX1
  418.             MCLSTR=ITLAC(IEL)
  419.             SEGACT MCLSTR
  420.             N=ISOSTR(/1)
  421.             ILENA(1)=N
  422.             ITOTO=1
  423.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  424.             CALL ECDIFE (IOSAU,N    ,ISOSTR,IFORM)
  425.             CALL ECDIFE (IOSAU,N    ,IRIGCL,IFORM)
  426.             SEGDES MCLSTR
  427.  60      CONTINUE
  428.          GOTO 1098
  429. C ********************************ELEM STRUC
  430.  6007    CONTINUE
  431.          DO 70 IEL=IDEB,IMAX1
  432.             MELSTR=ITLAC(IEL)
  433.             SEGACT MELSTR
  434.             N=ISOSTU(/1)
  435.             ILENA(1)=N
  436.             ITOTO=1
  437.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  438.             CALL ECDIFE (IOSAU,N    ,ISOSTU,IFORM)
  439.             CALL ECDIFE (IOSAU,N    ,IMELEM,IFORM)
  440.             SEGDES MELSTR
  441.  70      CONTINUE
  442.          GOTO 1098
  443. C     ********************MSOLUT*************************************
  444.  6008    CONTINUE
  445. C---- TRAITE PLUS LOIN  EN FIN DE SP -------------------------------
  446.          GOTO 1099
  447. C     ********************MSTRUC*************************************
  448.  6009    CONTINUE
  449.          DO 1900 IEL=IDEB,IMAX1
  450.             MSTRUC=ITLAC(IEL)
  451.             SEGACT MSTRUC
  452.             NS=LISTRU(/1)
  453.             ILENA(1)=NS
  454.             ITOTO=1
  455.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  456.             CALL ECDIFE(IOSAU,NS,LISTRU,IFORM)
  457.             SEGDES MSTRUC
  458.  1900    CONTINUE
  459.          GOTO 1098
  460. C     ******************************* MTABLE **************************
  461.  6010    CONTINUE
  462.          NTOTO=6
  463.          if(meffac.ne.0) segact meffac
  464.          DO 710 IEL=IDEB,IMAX1
  465.             MMM=0
  466.             MTABLE=ITLAC(IEL)
  467.             IF (MTABLE.EQ.0) GOTO 109
  468.             SEGACT MTABLE
  469.             L6=MLOTAB
  470.             L=L6
  471.             NN=0
  472.             SEGINI ITBBE1
  473.             IF (L.EQ.0) GOTO 109
  474.             DO 711 K=1,L
  475.                ITYPE=MTABTI(K)
  476.                JI=0
  477. *             IF(ITYPE.EQ.'METHODE ') ITYPE='MOT     '
  478.                CALL  TYPFIL (ITYPE,JI)
  479.                IF(JI.LE.0) GOTO 711
  480.                ITYPE=MTABTV(K)
  481.                J=0
  482.                CALL  TYPFIL (ITYPE,J)
  483.                IF(J.LE.0) GOTO 711
  484. *  on ne sauve pas les fantomes si on n'est pas en increment
  485.                 if (ipsauv.eq.0.and.j.eq.47) then
  486.                       segact mtable*mod
  487.                       MTABTV(K)='ANNULE'
  488.                       segact     mtable
  489.                       goto 711
  490.                 endif
  491.                IVA=MTABII(K)
  492.                ITABE1(**)=JI
  493.                ITABE1(**)=IVA
  494.                IVA=MTABIV(K)
  495. * on remplace les procedures par des entiers valant ?.
  496.                if( j.eq.36) then
  497.                  j = 26
  498.                  iva= 1
  499.                endif
  500.                if(j.eq.47) then
  501.                  itype = tyeffa(iva)
  502.                  j=0
  503.                  call typfil(itype,j)
  504.                  iva= neffac(iva)
  505.                endif
  506.                ITABE1(**)=J
  507.                ITABE1(**)=IVA
  508.  711        CONTINUE
  509.             MMM=ITABE1(/1)
  510.  109        ITOTO=1
  511.             ILENA(1)=MMM
  512.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  513.             IF (MTABLE.EQ.0) GOTO 710
  514.             CALL ECDIFE (IOSAU,MMM,ITABE1,IFORM)
  515.             SEGSUP ITBBE1
  516.  713        SEGDES MTABLE
  517.  710     CONTINUE
  518.          GOTO 1098
  519.  715     CONTINUE
  520.          MOTERR(1:8)=ITYPE
  521.          CALL ERREUR (336)
  522.          SEGDES MTABLE
  523.          SEGSUP ITBBE1
  524.          GOTO 1099
  525. C     *****************************        *****************************
  526.  6011    CONTINUE
  527.          GOTO 1098
  528. C     *************************MSOSTU*******************************
  529.  6012    CONTINUE
  530.          NN=3
  531.          SEGINI ITBBE1
  532.          DO 2201 IEL=IDEB,IMAX1
  533.             MSOSTU=ITLAC(IEL)
  534.             IF(MSOSTU.EQ.0) GOTO 2201
  535.             SEGACT MSOSTU
  536.             NS=ISCHAM(/1)
  537.             ITOTO    = 1
  538.             ILENA(1)=NS
  539.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  540.             ITOTO=3+NS
  541.             NN=ITOTO
  542.             SEGADJ ITBBE1
  543.             ITABE1(1)=ITYSOU
  544.             ITABE1(2)=ISRAID
  545.             ITABE1(3)=ISMASS
  546.             CALL JDANSI(ITABE1(4),ISCHAM(1),NS)
  547.             CALL ECDIFE (IOSAU,ITOTO,ITABE1(1),IFORM)
  548.             SEGDES MSOSTU
  549.  2201    CONTINUE
  550.          SEGSUP ITBBE1
  551.          GOTO 1098
  552. C     ***************************** IMATRI *****************************
  553.  6013    CONTINUE
  554.          DO 2300 IEL=IDEB,IMAX1
  555.               xmatri=itlac(iel)
  556.               segact xmatri
  557.               lval=re(/1)*re(/2)*re(/3)
  558.               ilena(1)=re(/1)
  559.               ilena(2)=re(/2)
  560.               ilena(3)=re(/3)
  561.               ilena(4)=symre
  562. ***           write (6,*) ' imatri ',iel,re(/1),re(/2),re(/3),symre
  563.               itoto=4
  564.               CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  565.               if (symre.eq.0.and.ilena(1).eq.ilena(2)) then
  566. *  cas symetrique on  ne sauve que la partie triangulaire
  567.               laux = ilena(1)*(ilena(1)+1)/2
  568.               nelrig=ilena(3)
  569.               segini xmaaux
  570.               do k=1,nelrig
  571.                ip=0
  572.                do j=1,ilena(2)
  573.                 do i=1,j
  574.                  reaux(ip+i,k)=re(i,j,k)
  575. *  Les raideurs calculees avec hook ne sont pas tres symetriques
  576.                  if (abs(re(i,j,k)-re(j,i,k)).gt.
  577.      >           (abs(re(i,j,k))+abs(re(j,i,k)))*xzprec*1d4+xpetit) then
  578.                    call erreur(969)
  579. **                 write(6,*) re(i,j,k),re(j,i,k)
  580.                  endif
  581.                 enddo
  582.                 ip=ip+j
  583.                enddo
  584.                if (ip.ne.laux) call erreur(5)
  585.               enddo
  586.               call ecdifr(iosau,ip*nelrig,reaux,iform)
  587.               segsup xmaaux
  588.               else
  589. *  cas general on sauve tout
  590.               CALL ECDIFR(IOSAU,lval,re,IFORM)
  591.               endif
  592.               segdes xmatri
  593.  2300    CONTINUE
  594.          GOTO 1098
  595. C     ***************************** MJONCT *****************************
  596.  6014    CONTINUE
  597.          CALL WRJONC (IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  598.          GOTO 1098
  599. C     ***************************** MATTAC *****************************
  600.  6015    CONTINUE
  601.          CALL WRATTA (IOSAU,ITLACC,IMAX1,IRETOU,IFORM,IDEB)
  602.          GOTO 1098
  603. C     ***************************** MMATRI *****************************
  604.  6016    CONTINUE
  605.          CALL WRMMAT (IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  606.          GOTO 1098
  607. C     *********************MDEFOR***********************************
  608.  6017    CONTINUE
  609.          DO 2700 IEL=IDEB,IMAX1
  610.             MDEFOR=ITLAC(IEL)
  611.             SEGACT MDEFOR
  612.             NDEF=IELDEF(/1)
  613.             ILENA(1)= NDEF
  614.             ITOTO   = 1
  615.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  616.             CALL ECDIFR(IOSAU,NDEF,AMPL,IFORM)
  617.             NN=7*NDEF
  618.             SEGINI ITBBE1
  619.             CALL JDANSI (ITABE1(1),       IELDEF(1),NDEF)
  620.             CALL JDANSI (ITABE1(NDEF+1),  ICHDEF(1),NDEF)
  621.             CALL JDANSI (ITABE1(2*NDEF+1),JCOUL(1),NDEF)
  622.             CALL JDANSI (ITABE1(3*NDEF+1),MTVECT(1),NDEF)
  623.             CALL JDANSI (ITABE1(4*NDEF+1),MDCHP(1),NDEF)
  624.             CALL JDANSI (ITABE1(5*NDEF+1),MDCHEL(1),NDEF)
  625.             CALL JDANSI (ITABE1(6*NDEF+1),MDMODE(1),NDEF)
  626.             CALL ECDIFE (IOSAU,NN,ITABE1,IFORM)
  627.             SEGSUP ITBBE1
  628. C
  629.             SEGDES MDEFOR
  630.  2700    CONTINUE
  631.          GOTO 1098
  632. C     ***************************MLREEL******************************
  633.  6018    CONTINUE
  634.          DO 2800 IEL=IDEB,IMAX1
  635.             MLREEL=ITLAC(IEL)
  636.             SEGACT MLREEL
  637.             L=PROG(/1)
  638.             ILENA(1)=L
  639.             ITOTO=1
  640.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  641.             CALL ECDIFR(IOSAU,L,PROG,IFORM)
  642.             SEGDES MLREEL
  643.  2800    CONTINUE
  644.          GOTO 1098
  645. C     *****************************MLENTI***************************
  646.  6019    CONTINUE
  647.          DO 2900 IEL=IDEB,IMAX1
  648.             MLENTI=ITLAC(IEL)
  649.             SEGACT MLENTI
  650.             L=LECT(/1)
  651.             ILENA(1)=L
  652.             ITOTO=1
  653.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  654.             CALL ECDIEE(IOSAU,L,LECT,IFORM)
  655.             SEGDES MLENTI
  656.  2900    CONTINUE
  657.          GOTO 1098
  658. C     ****************************MCHARG*****************************
  659.  6020    CONTINUE
  660.          NN=0
  661.          NM=0
  662.          NM2=0
  663.          SEGINI ITBBM1,itbbc1
  664.          SEGINI ITBBM2,itbbc3
  665.          SEGINI ITBBM3,itbbc4
  666.          SEGINI ITBBM4,itbbc5
  667.          SEGINI ITBBE1
  668.          SEGINI ITBBE2,itbbc2
  669.          DO 3000 IEL=IDEB,IMAX1
  670.            IF (IONIVE.GT.10) THEN
  671.             MCHARG=ITLAC(IEL)
  672.             SEGACT MCHARG*mod
  673.             N=KCHARG(/1)
  674.             ILENA(1)=N
  675.             ITOTO=1
  676.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  677.             NN=2*N
  678.             SEGADJ ITBBE2,itbbc2
  679.             NM=2*N
  680.             SEGADJ ITBBM1,itbbc1
  681.             NM2=N
  682.             SEGADJ ITBBM2,itbbc3
  683.             SEGADJ ITBBM3,itbbc4
  684.             SEGADJ ITBBM4,itbbc5
  685.             NN=7*N
  686.             SEGADJ ITBBE1
  687.             DO 3003 I=1,N
  688.                ICHARG=KCHARG(I)
  689.                SEGACT ICHARG*mod
  690.                I2=2*I
  691.                I3=7*I
  692.                if (ichar(chatyp(1:1)).eq.0) chatyp=' '
  693.                READ (CHATYP,FMT='(2A4)') ITABM1(I2-1),ITABM1(I2)
  694.                itabc1(i2-1)=chatyp(1:4)
  695.                itabc1(i2)=chatyp(5:8)
  696.                if (ichar(chanat(i)(1:1)).eq.0) chanat(i)=' '
  697.                READ (CHANAT(I),FMT='(2A4)') ITABE2(I2-1),ITABE2(I2)
  698.                itabc2(i2-1)=chanat(i)(1:4)
  699.                itabc2(i2)=chanat(i)(5:8)
  700.                if (ichar(chanom(i)(1:1)).eq.0) chanom(i)=' '
  701.                READ (CHANOM(I),FMT='(1A4)') ITABM2(I)
  702.                itabc3(i)=chanom(i)
  703.                if (ichar(chamob(i)(1:1)).eq.0) chamob(i)=' '
  704.                READ (CHAMOB(I),FMT='(1A4)') ITABM3(I)
  705.                itabc4(i)=chamob(i)
  706.                if (ichar(chalie(i)(1:1)).eq.0) chalie(i)=' '
  707.                READ (CHALIE(I),FMT='(1A4)') ITABM4(I)
  708.                itabc5(i)=chalie(i)
  709.                ITABE1(I3-6)=ICHPO1
  710.                ITABE1(I3-5)=ICHPO2
  711.                ITABE1(I3-4)=ICHPO3
  712.                ITABE1(I3-3)=ICHPO4
  713.                ITABE1(I3-2)=ICHPO5
  714.                ITABE1(I3-1)=ICHPO6
  715.                ITABE1(I3)  =ICHPO7
  716.                SEGDES ICHARG
  717.  3003       CONTINUE
  718.             if (iform.ne.2) then
  719.               CALL ECDIFM(IOSAU,2*N,ITABE2,IFORM)
  720.               CALL ECDIFM(IOSAU,N,ITABM2,IFORM)
  721.               CALL ECDIFM(IOSAU,N,ITABM3,IFORM)
  722.               CALL ECDIFM(IOSAU,N,ITABM4,IFORM)
  723.               CALL ECDIFM(IOSAU,NM,ITABM1,IFORM)
  724.             endif
  725.             if (iform.eq.2) then
  726.               ios=IXDRSTRING( ixdrw, itabc2(1)(1:4*2*n))
  727.               ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*n))
  728.               ios=IXDRSTRING( ixdrw,itabc4(1)(1:4*n))
  729.               ios=IXDRSTRING( ixdrw,itabc5(1)(1:4*n))
  730.               ios=IXDRSTRING( ixdrw,itabc1(1)(1:4*nm))
  731.             endif
  732.             dimatt = dimatt + (5*n) +nm
  733.             CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  734.             SEGDES MCHARG
  735.  
  736. C= Niveaux < 10 :
  737.             ELSE IF(IONIVE.GE.7.AND.IONIVE.LE.10) THEN
  738.                MCHARG=ITLAC(IEL)
  739.                SEGACT MCHARG*mod
  740.                N=KCHARG(/1)
  741.                ILENA(1)=N
  742.                ITOTO=1
  743.                CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  744.                NN=2*N
  745.                SEGADJ ITBBE2,itbbc2
  746.                NM=2*N
  747.                SEGADJ ITBBM1,itbbc1
  748.                NM2=N
  749.                SEGADJ ITBBM2,itbbc3
  750.                NN=3*N
  751.                SEGADJ ITBBE1
  752.                DO 3002 I=1,N
  753.                   ICHARG=KCHARG(I)
  754.                   SEGACT ICHARG*mod
  755.                   I2=2*I
  756.                   I3=3*I
  757.                   if (ichar(chatyp(1:1)).eq.0) chatyp=' '
  758.                   READ (CHATYP,FMT='(2A4)') ITABM1(I2-1),ITABM1(I2)
  759.                   itabc1(i2-1)=chatyp(1:4)
  760.                   itabc1(i2)=chatyp(5:8)
  761.                   if (ichar(chanat(i)(1:1)).eq.0) chanat(i)=' '
  762.                   READ (CHANAT(I),FMT='(2A4)') ITABE2(I2-1),ITABE2(I2)
  763.                   itabc2(i2-1)=chanat(i)(1:4)
  764.                   itabc2(i2)=chanat(i)(5:8)
  765.                   if (ichar(chanom(i)(1:1)).eq.0) chanom(i)=' '
  766.                   READ (CHANOM(I),FMT='(1A4)') ITABM2(I)
  767.                   itabc3(i)=chanom(i)
  768.                   ITABE1(I3-2)=ICHPO1
  769.                   ITABE1(I3-1)=ICHPO2
  770.                   ITABE1(I3)=ICHPO3
  771.                   SEGDES ICHARG
  772.  3002          CONTINUE
  773.                if (iform.ne.2) CALL ECDIFM(IOSAU,2*N,ITABE2,IFORM)
  774.                if (iform.eq.2)ios=IXDRSTRING( ixdrw, itabc2(1)(1:4*2*n))
  775.                if (iform.ne.2) CALL ECDIFM(IOSAU,N,ITABM2,IFORM)
  776.                if (iform.eq.2) ios=IXDRSTRING( ixdrw, itabc3(1)(1:4*n))
  777.                if (iform.ne.2) CALL ECDIFM(IOSAU,NM,ITABM1,IFORM)
  778.                if (iform.eq.2) ios=IXDRSTRING( ixdrw, itabc1(1)(1:4*nm))
  779.                dimatt = dimatt + (3*n) +nm
  780.                CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  781.                SEGDES MCHARG
  782.            ELSE
  783.                MCHARG=ITLAC(IEL)
  784.                SEGACT MCHARG*mod
  785.                N=KCHARG(/1)
  786.                ILENA(1)=N
  787.                ITOTO=1
  788.                CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  789.                NM=2*N
  790.                SEGADJ ITBBM1,itbbc1
  791.                NN=3*N
  792.                SEGADJ ITBBE1
  793.                DO 3001 I=1,N
  794.                   ICHARG=KCHARG(I)
  795.                   SEGACT ICHARG*mod
  796.                   IF(CHATYP.NE.'CHPOINT ') THEN
  797. *---- cas du nouveau chargement . Incompatible avec niveau 6 ----
  798.                      CALL ERREUR(691)
  799.                      GOTO 1099
  800.                   ENDIF
  801.                   I2=2*I
  802.                   I3=3*I
  803.                   if (ichar(chanat(i)(1:1)).eq.0) chanat(i)=' '
  804.                   READ (CHANAT(I),FMT='(2A4)') ITABM1(I2-1),ITABM1(I2)
  805.                   itabc1(i2-1)=chanat(i)(1:4)
  806.                   itabc1(i2)=chanat(i)(5:8)
  807.                   ITABE1(I3-2)=ICHPO1
  808.                   ITABE1(I3-1)=ICHPO2
  809.                   ITABE1(I3  )=ICHPO3
  810.                   SEGDES ICHARG
  811.  3001          CONTINUE
  812.                if (iform.ne.2) CALL ECDIFM(IOSAU,NM,ITABM1,IFORM)
  813.                if (iform.eq.2) then
  814.                 ios=IXDRSTRING( ixdrw, itabc1(1)(1:nm*4))
  815.                 dimatt = dimatt + nm
  816.                endif
  817.                CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  818.                SEGDES MCHARG
  819.             ENDIF
  820.  
  821.  3000    CONTINUE
  822.          SEGSUP ITBBE1,ITBBM1,itbbc1,ITBBE2,itbbc2,ITBBM2,itbbc3,
  823.      &          ITBBM3,itbbc4,ITBBM4,itbbc5
  824.          GOTO 1098
  825.  
  826. C     ****************************        **************************
  827.  6021    CONTINUE
  828.          GOTO 1098
  829. C     *****************************MEVOLL***************************
  830.  6022    CONTINUE
  831.          NN=0
  832.          NM=0
  833.          NM2=20
  834.          SEGINI ITBBM2,itbbc3
  835.          SEGINI ITBBE2,itbbc2
  836.          SEGINI ITBBE1,ITBBM1,itbbc1
  837.          LDECA = 11
  838.          if (ionive.lt.3) LDECA = 7
  839.          LDECA2=18
  840.          DO 3200 IEL=IDEB,IMAX1
  841.             MEVOLL=ITLAC(IEL)
  842.             SEGACT MEVOLL*mod
  843.             N=IEVOLL(/1)
  844.             ILENA(1)=N
  845.             ITOTO=1
  846.             NM2=20
  847.             SEGADJ ITBBM2,itbbc3
  848.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  849.             READ (ITYEVO,FMT='(2A4)') ITABM2(1),ITABM2(2)
  850.             itabc3(1)=ityevo(1:4)
  851.             itabc3(2)=ityevo(5:8)
  852.             if (ichar(ievtex(1:1)).eq.0) ievtex=' '
  853.             READ (IEVTEX,FMT='(18A4)') (ITABM2(2+JPV),JPV=1,18)
  854.             do jpv=1,18
  855.              itabc3(2+jpv)=ievtex(1+(jpv-1)*4:jpv*4)
  856.             enddo
  857.             if (iform.ne.2) CALL ECDIFM (IOSAU,NM2,ITABM2,IFORM)
  858.             if (iform.eq.2) then
  859.              ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*nm2))
  860.              dimatt = dimatt + nm2
  861.             endif
  862.             IF (IONIVE.GE.25) THEN
  863.               NN=6*N
  864.             ELSE
  865.               NN=3*N
  866.             ENDIF
  867.             SEGADJ ITBBE1
  868.             NM=LDECA*N
  869.             SEGADJ ITBBM1,itbbc1
  870.             NM2=LDECA2*N
  871.             SEGADJ ITBBM2,itbbc3
  872. C        LOOP SUR LES KEVOL-
  873.             DO 3201 IN=1,N
  874.                KEVOLL=IEVOLL(IN)
  875.                SEGACT KEVOLL*mod
  876.                IF (IONIVE.GE.25) THEN
  877.                  I4=6*IN
  878.                  ITABE1(I4-5)= IPROGX
  879.                  ITABE1(I4-4)= IPROGY
  880.                  ITABE1(I4-3)= NUMEVX
  881.                  ITABE1(I4-2)= LSTYL
  882.                  ITABE1(I4-1)= MMARQ
  883.                  ITABE1(I4  )= KTAIL
  884.                ELSE
  885.                  I4=3*IN
  886.                  ITABE1(I4-2)= IPROGX
  887.                  ITABE1(I4-1)= IPROGY
  888.                  ITABE1(I4  )= NUMEVX
  889.                ENDIF
  890.                I7=LDECA*(IN-1)
  891.                I8=LDECA2*(IN-1)
  892.                if (ichar(nomevx(1:1)).eq.0) nomevx=' '
  893.                READ (NOMEVX,FMT='(3A4)') (ITABM1(I7+I),I=1,3)
  894.                itabc1(i7+1)=nomevx(1:4)
  895.                itabc1(i7+2)=nomevx(5:8)
  896.                itabc1(i7+3)=nomevx(9:12)
  897.                if (ichar(nomevy(1:1)).eq.0) nomevy=' '
  898.                READ (NOMEVY,FMT='(3A4)') (ITABM1(I7+I+3),I=1,3)
  899.                itabc1(i7+3+1)=nomevy(1:4)
  900.                itabc1(i7+3+2)=nomevy(5:8)
  901.                itabc1(i7+3+3)=nomevy(9:12)
  902.                if (ichar(numevy(1:1)).eq.0) numevy=' '
  903.                READ (NUMEVY,FMT='(A4)') ITABM1(I7 +7)
  904.                itabc1(i7+7)=numevy
  905.                IF(IONIVE.GE.3) THEN
  906.                   if (ichar(typx(1:1)).eq.0) typx=' '
  907.                   READ (TYPX,FMT='(2A4)') (ITABM1(I7+7+I),I=1,2)
  908.                   itabc1(i7+7+1)=typx(1:4)
  909.                   itabc1(i7+7+2)=typx(5:8)
  910.                   if (ichar(typy(1:1)).eq.0) typy=' '
  911.                   READ (TYPY,FMT='(2A4)') (ITABM1(I7+9+I),I=1,2)
  912.                   itabc1(i7+9+1)=typy(1:4)
  913.                   itabc1(i7+9+2)=typy(5:8)
  914.                   if (ichar(kevtex(1:1)).eq.0) kevtex=' '
  915.                   READ(KEVTEX,FMT='(18A4)')(ITABM2(I8+JPV),JPV=1,18)
  916.                   do jpv=1,18
  917.                    itabc3(i8+jpv)=kevtex(1+(jpv-1)*4:4*jpv)
  918.                   enddo
  919.                ENDIF
  920.                SEGDES KEVOLL
  921.  3201       CONTINUE
  922.             SEGDES MEVOLL
  923.             IF (IONIVE.GE.25) THEN
  924.               NN=6*N
  925.             ELSE
  926.               NN=3*N
  927.             ENDIF
  928.             CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  929.             NN=LDECA*N
  930.             if (iform.ne.2) CALL ECDIFM(IOSAU,NN,ITABM1,IFORM)
  931.             if (iform.eq.2) then
  932.              ios=IXDRSTRING( ixdrw,itabc1(1)(1:4*nn))
  933.              dimatt = dimatt + nn
  934.             endif
  935.             IF(IONIVE.GE.3) then
  936.              if (iform.ne.2) CALL ECDIFM (IOSAU,NM2,ITABM2,IFORM)
  937.              if (iform.eq.2) then
  938.               ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*nm2))
  939.               dimatt = dimatt + nm2
  940.             endif
  941.           endif
  942.  3200    CONTINUE
  943.          SEGSUP ITBBM2,itbbc3
  944.          SEGSUP ITBBE2,itbbc2
  945.          SEGSUP ITBBE1,ITBBM1,itbbc1
  946.          GOTO 1098
  947. C     **********************SUPERELE************************************
  948.  6023    CONTINUE
  949.          NTOTO=6
  950.          ITOTO=1
  951.          DO 230 IEL=IDEB,IMAX1
  952.             MSUPER=ITLAC(IEL)
  953.             SEGACT MSUPER
  954.             ILENA(1)=NTOTO
  955.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  956.             ILENA(1)=MRIGTO
  957.             ILENA(2)=MSUPEL
  958.             ILENA(3)=MSURAI
  959.             ILENA(4)=MBLOQU
  960.             ILENA(5)=MSUMAS
  961. C *** On ecrit MCROUT pour memoire mais il ne sera pas sauve (MMATRI)
  962.             ILENA(6)=MCROUT
  963.             CALL ECDIFE (IOSAU,NTOTO,ILENA,IFORM)
  964.             SEGDES MSUPER
  965.  230     CONTINUE
  966.          GOTO 1098
  967. C     ************************* LOGIQUE  ***************************
  968.  6024    CONTINUE
  969.          ITOTO=1
  970.          IVLON=IMAX1-IDEB+1
  971.          ILENA(1)=IVLON
  972.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  973.          NN=IVLON
  974.          SEGINI ITBBE1
  975.          DO 240 I=1,IVLON
  976.             IVA=ITLAC(I+IDEB-1)
  977.             CALL QUEVAL(IVA,'LOGIQUE ',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  978.             IF(LIRA)ITOTO=1
  979.             IF(.NOT.LIRA)ITOTO=0
  980.             ITABE1(I)=ITOTO
  981.  240     CONTINUE
  982.          CALL ECDIFE( IOSAU,IVLON,ITABE1(1),IFORM)
  983.          SEGSUP ITBBE1
  984.          GOTO 1098
  985. C     ************************* FLOTTANT ***************************
  986.  6025    CONTINUE
  987.          ITOTO=1
  988.          IVLON=IMAX1-IDEB+1
  989.          ILENA(1)=IVLON
  990.          L=IVLON
  991.          SEGINI ITABR1
  992.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  993.          DO 250 I=1,IVLON
  994.             IVA=ITLAC(I+IDEB-1)
  995.             CALL QUEVAL(IVA,'FLOTTANT',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  996.             TABR1(I)=XRA
  997.  250     CONTINUE
  998.          CALL ECDIFR(IOSAU,IVLON,TABR1,IFORM)
  999.          SEGSUP ITABR1
  1000.          GOTO 1098
  1001. C     **************************** ENTIER***************************
  1002.  6026    CONTINUE
  1003.          IVLON=IMAX1-IDEB+1
  1004.          ILENA(1)=IVLON
  1005.          ITOTO=1
  1006.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1007.          NN=IVLON
  1008.          SEGINI ITBBE1
  1009. *        write (6,*) ' wrpil ideb ivlon itlacc ',ideb,ivlon,itlacc
  1010.          DO 260 I=1,IVLON
  1011.             IVA=ITLAC(I+IDEB-1)
  1012.             CALL QUEVAL(IVA,'ENTIER  ',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  1013.             ITABE1(I)=IVALIN
  1014.  260     CONTINUE
  1015. *        write (6,*) ' wrpil entiers ',(itabe1(i),i=1,ivlon)
  1016.          CALL ECDIEE( IOSAU,IVLON,ITABE1(1),IFORM)
  1017.          GOTO 1098
  1018. C     **************************** MOT   ***************************
  1019.  6027    CONTINUE
  1020.          NN=0
  1021.          NNN=0
  1022.          SEGINI ITAMOT
  1023.          IVLON=IMAX1-IDEB+1
  1024.          DO 270 I=1,IVLON
  1025.             IVA=ITLAC(I+IDEB-1)
  1026. C  CHA1 EST UNE CHAINE DE 512 CARACTERES
  1027.             CALL QUEVAL(IVA,'MOT     ',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  1028.             NN1=NN
  1029.             NN=NN+IVALIN
  1030.             NNN=NNN+1
  1031.             SEGADJ ITAMOT
  1032.             ICOTA(NNN)=NN
  1033.             ITAMO(1+NN1:IVALIN+NN1)=CHA1(1:IVALIN)
  1034.  270     CONTINUE
  1035.          ILENA(1)=NN
  1036.          ITOTO=2
  1037.          ILENA(2)=IVLON
  1038.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1039.          CALL ECDIFC( IOSAU,ITAMO,IFORM)
  1040.          CALL ECDIFE( IOSAU,IVLON,ICOTA,IFORM)
  1041.          SEGSUP ITAMOT
  1042.          GOTO 1098
  1043. C     ****************************TEXTE    *************************
  1044.  6028    CONTINUE
  1045.          DO 2928 IEL=IDEB,IMAX1
  1046.             MTEXTE=ITLAC(IEL)
  1047.             SEGACT MTEXTE
  1048. CCCC  L       =(NCART+3)/4
  1049.             L=NCART
  1050.             ITOTO=1
  1051.             ILENA(1)=L
  1052.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1053.             CALL ECDIFC( IOSAU,MTEXT,IFORM)
  1054.             SEGDES MTEXTE
  1055.  2928    CONTINUE
  1056.          GOTO 1098
  1057. C     ****************************LISTMOTS *************************
  1058.  6029    CONTINUE
  1059.          DO 2929 IEL=IDEB,IMAX1
  1060.             MLMOTS=ITLAC(IEL)
  1061.             SEGACT MLMOTS
  1062.             ILENA(1)=MOTS(/1)
  1063.             ILENA(2)=MOTS(/2)
  1064.             ITOTO=2
  1065.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1066.             NNA=ILENA(1)
  1067.             NNN = 0
  1068.             NN = ILENA(1)*ILENA(2)
  1069.             SEGINI ITAMOT
  1070.             DO 2930 IMM=1,ILENA(2)
  1071.                ITAMO((IMM-1)*NNA+1:IMM*NNA)=MOTS(IMM)
  1072.  2930       CONTINUE
  1073.             CALL ECDIFC( IOSAU,ITAMO,IFORM)
  1074.             SEGDES MLMOTS
  1075.             SEGSUP ITAMOT
  1076.  2929    CONTINUE
  1077.          GOTO 1098
  1078. C     **************************** VECTEUR**************************
  1079.  6030    CONTINUE
  1080.          DO 300 IEL=IDEB,IMAX1
  1081.             MVECTE =ITLAC(IEL)
  1082.             CALL WRVECT (MVECTE,IOSAU,IRETOU,IFORM)
  1083.  300     CONTINUE
  1084.          GOTO 1098
  1085. C     ************************* VECTD    ***************************
  1086.  6031    CONTINUE
  1087.          DO 310 IEL=IDEB,IMAX1
  1088.             MVECTD=ITLAC(IEL)
  1089.             SEGACT MVECTD
  1090.             INC=VECTBB(/1)
  1091.             ILENA(1)=INC
  1092.             ITOTO=1
  1093.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1094.             CALL ECDIFR(IOSAU,INC,VECTBB,IFORM)
  1095.             SEGDES MVECTD
  1096.  310     CONTINUE
  1097.          GOTO 1098
  1098. C     ************************* POINT    ***************************
  1099.  6032    CONTINUE
  1100. * on sauve tout le itlac car numerotation a pu changer
  1101.          ILENA(1)=IMAX1
  1102.          ITOTO=1
  1103.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1104.          CALL ECDIFE( IOSAU,IMAX1,ITLAC,IFORM)
  1105.          GOTO 1098
  1106. C     ************************* CONFIG   ***************************
  1107.  6033    CONTINUE
  1108.          CALL WRCONF(IOSAU,ITLACC,IMAX1,IFORM,IDEB,IDIM,MCOORD)
  1109.          GOTO 1098
  1110. C     ******************* MLCHPO ************************************
  1111.  6034    CONTINUE
  1112.          DO 340 IEL=IDEB,IMAX1
  1113.             MLCHPO=ITLAC(IEL)
  1114.             SEGACT MLCHPO
  1115.             N1=ICHPOI(/1)
  1116.             ILENA(1)=N1
  1117.             ITOTO=1
  1118.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  1119.             CALL ECDIFE(IOSAU,N1,ICHPOI,IFORM)
  1120.             SEGDES MLCHPO
  1121.  340     CONTINUE
  1122.          GOTO 1098
  1123. C     ****************************MBASEM*****************************
  1124.  6035    CONTINUE
  1125.          NN=0
  1126.          DO 3500 IEL=IDEB,IMAX1
  1127.             MBASEM=ITLAC(IEL)
  1128.             SEGACT MBASEM
  1129.             N=LISBAS(/1)
  1130.             ITOTO=1
  1131.             ILENA(1)=N
  1132.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1133.             ITOTO=1
  1134.             DO 3501 I=1,N
  1135.                MSOBAS=LISBAS(I)
  1136.                SEGACT MSOBAS
  1137.                NIBST=IBSTRM(/1)
  1138.                ILENA(1)=NIBST
  1139.                CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1140.                CALL ECDIFE(IOSAU,NIBST,IBSTRM(1),IFORM)
  1141.                SEGDES MSOBAS
  1142.  3501       CONTINUE
  1143.             SEGDES MBASEM
  1144.  3500    CONTINUE
  1145.          GOTO 1098
  1146. C     **********************PROCEDUR************************************
  1147.  6036    CONTINUE
  1148.          GOTO 1098
  1149. C     **********************BLOC****************************************
  1150.  6037    CONTINUE
  1151.          GOTO 1098
  1152. C     *********************** MODELE MMODEL ****************************
  1153.  6038    CONTINUE
  1154.          CALL WRMODL(IOSAU,ITLACC,IDEB,IMAX1,IONIVE,IFORM)
  1155.          GOTO 1098
  1156. C     *********************** MCHAML ***********************************
  1157.  6039    CONTINUE
  1158.          CALL WRCHAM(IOSAU,ITLACC,IMAX1,IFORM,IONIVE,IDEB)
  1159.          GOTO 1098
  1160. C     **************************  MINTE  *******************************
  1161.  6040    CONTINUE
  1162.          L=50*4+6*50*40
  1163.          SEGINI ITABR1
  1164.          DO 2840 IEL=IDEB,IMAX1
  1165.             MINTE=ITLAC(IEL)
  1166.             SEGACT MINTE
  1167.             NBNO  =SHPTOT(/2)
  1168.             NBPGAU=SHPTOT(/3)
  1169.             ITOTO = 2
  1170.             ILENA(1) = NBNO
  1171.             ILENA(2) = NBPGAU
  1172.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  1173.             LR1=NBPGAU*4+6*NBPGAU*NBNO
  1174.             if (LR1.gt.L) then
  1175.               write(ioimp,*) 'WRPIL - MINTE - segadj',L,LR1
  1176.               L = LR1
  1177.               segadj,ITABR1
  1178.             endif
  1179.             I=0
  1180.             DO 2841 IC=1,NBPGAU
  1181.                I=I+1
  1182.                TABR1(I)=POIGAU(IC)
  1183.                I=I+1
  1184.                TABR1(I)=QSIGAU(IC)
  1185.                I=I+1
  1186.                TABR1(I)=ETAGAU(IC)
  1187.                I=I+1
  1188.                TABR1(I)=DZEGAU(IC)
  1189.                DO 2842 IB=1,NBNO
  1190.                   DO 2843 IA=1,6
  1191.                      I=I+1
  1192.                      TABR1(I)=SHPTOT(IA,IB,IC)
  1193.  2843             CONTINUE
  1194.  2842          CONTINUE
  1195.  2841       CONTINUE
  1196.             CALL ECDIFR(IOSAU,LR1,TABR1,IFORM)
  1197.             SEGDES MINTE
  1198.  2840    CONTINUE
  1199.          SEGSUP ITABR1
  1200.          GOTO 1098
  1201. C     *********************** NUAGE ***************************
  1202.  6041    CONTINUE
  1203.          CALL WRNUAG(IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  1204.          GOTO 1098
  1205. C     ********************** MATRAK *********************************
  1206.  6042    CONTINUE
  1207.          CALL WRMTAK(IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  1208.          GOTO 1098
  1209. C     ********************** MATRIK *********************************
  1210.  6043    CONTINUE
  1211.          CALL WRMTIK(IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  1212.          GOTO 1098
  1213. C     *****************************METHODE *********************
  1214.  6045    CONTINUE
  1215.          IVLON=IMAX1-IDEB+1
  1216. C      APPELE PAR WRPI
  1217.          ILENA(1)=IVLON
  1218.          ITOTO=1
  1219.          CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  1220.          CALL ECDIFE(IOSAU,IVLON,ITLAC(IDEB),IFORM)
  1221.          GOTO 1098
  1222.  
  1223. C     *********************** IELVAL ***********************************
  1224.  6048    CONTINUE
  1225. C  Ecriture des IELVAL depuis le niveau 20 :
  1226.          if (IONIVE.lt.20) goto 1098
  1227.          CALL WRIELV(IOSAU,ITLACC,IDEB,IMAX1,IONIVE,IFORM)
  1228.          GOTO 1098
  1229.  
  1230. C     *********************** ANNOTATI *********************************
  1231.  6049    CONTINUE
  1232.          GOTO 1098
  1233. C     *********************** LISTOBJE**********************************
  1234.  6050    CONTINUE
  1235.          DO 550 IEL=IDEB,IMAX1
  1236.             MLOBJE=ITLAC(IEL)
  1237.             IF (MLOBJE.EQ.0) GOTO 550
  1238.             SEGACT, MLOBJE
  1239.             N1=LISOBJ(/1)
  1240.             ITYPO = TYPOBJ
  1241. C           write(6,*) '**** ITYPO=',ITYPO
  1242.             ILENA(1)=N1
  1243.             ITOTO=1
  1244.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  1245.             NM2 = 2
  1246.             SEGINI, ITBBM2,itbbc3
  1247.             READ (ITYPO,FMT='(2A4)') ITABM2(1),ITABM2(2)
  1248.             itabc3(1)=TYPOBJ(1:4)
  1249.             itabc3(2)=TYPOBJ(5:8)
  1250. C           write(6,*) '**** ITABM2=',ITABM2(1),ITABM2(2)
  1251.             if (iform.ne.2) CALL ECDIFM(IOSAU,NM2,ITABM2,IFORM)
  1252.             if (iform.eq.2) then
  1253.               ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*nm2))
  1254.               dimatt = dimatt + nm2
  1255.             endif
  1256. C           write(6,*) '**** LISOBJ(1)=',LISOBJ(1)
  1257.             CALL ECDIFE(IOSAU,N1,LISOBJ,IFORM)
  1258.             SEGDES, MLOBJE
  1259.  550     CONTINUE
  1260.          GOTO 1098
  1261.  
  1262. C     *********************** IMODEL ***********************************
  1263.  6051    CONTINUE
  1264. c-dbg         write(ioimp,*) 'WRPIL->WRIMOD',IONIVE
  1265. C  Ecriture des IMODEL depuis le niveau 26 :
  1266.          if (IONIVE.lt.26) goto 1098
  1267.          CALL WRIMOD(IOSAU,ITLACC,IDEB,IMAX1,IONIVE,IFORM)
  1268.          GOTO 1098
  1269.  
  1270. C     ******************************************************************
  1271.  
  1272.  1098    CONTINUE
  1273.  
  1274. C     ********************** Fin de boucle IFILE **********************
  1275.  1099 CONTINUE
  1276.  
  1277. C     **********************MSOLUT: TRAITE EN DERNIER*****************
  1278.       IFILE=8
  1279.       ITLACC=KCOLA(IFILE)
  1280.       IMAX1=ITLAC(/1)
  1281.       IDEB=1
  1282.       IF(IPSAUV.NE.0) IDEB=KCOLAC(IFILE)+1
  1283.       IF(IMAX1.LT.IDEB) GOTO 2099
  1284.       ITYPE='        '
  1285.       CALL TYPFIL(ITYPE,IFILE)
  1286.       WRITE(IOIMP,801)IFILE,IMAX1,ITYPE
  1287.       IP1=ICOLA(IFILE)
  1288.       ITLACC=KCOLA(IFILE)
  1289.  
  1290.       CALL NOMMEF(IP1,IMAX1,IFILE,IFORM,IDEB,isilen)
  1291.       if (IONIVE.le.2) goto 2099
  1292.       DO 1800 IEL=IDEB,IMAX1
  1293.          MSOLUT=ITLAC(IEL)
  1294.          CALL WRSOLU(MSOLUT,IRETOU,IFORM)
  1295.  1800 CONTINUE
  1296. C     *****************************************************************
  1297.  2099 CONTINUE
  1298. C
  1299.       IQUOI=5
  1300.       CALL ECDES(IOSAU,IQUOI,IFORM)
  1301.       IF (IFORM.EQ.0) WRITE(IOSAU) LABEL
  1302.       IF (IFORM.EQ.1) WRITE(IOSAU,772) LABEL
  1303.  772  FORMAT(A72)
  1304.       if (iform.eq.2) then
  1305.         ios=IXDRSTRING( ixdrw, label(1:72))
  1306.         dimatt = dimatt + 18
  1307.       else
  1308. *       sur certaines machines, la fermeture du fichier pouvait poser
  1309. *       probleme (buffer non ecrit avant de sortir de castem)
  1310.         CALL FLUSH(IOSAU)
  1311.       endif
  1312.  
  1313.       MOTERR=LABEL
  1314.       CALL ERREUR(-345)
  1315.       SEGDES,ICOLAC
  1316.  
  1317.       RETURN
  1318.       END
  1319.  
  1320.  
  1321.  

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