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

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