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    PASCAL    22/06/24    21:15:08     11393          
  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.       POINTEUR MCOOR1.MCOORD
  34. -INC SMSTRUC
  35. -INC SMDEFOR
  36. -INC SMLREEL
  37. -INC SMLENTI
  38. -INC SMCHARG
  39. -INC SMEVOLL
  40. -INC SMELSTR
  41. -INC SMCLSTR
  42. -INC SMTEXTE
  43. -INC SMSUPER
  44. -INC SMVECTD
  45. -INC SMLMOTS
  46. -INC SMTABLE
  47. -INC SMLCHPO
  48. -INC SMINTE
  49. -INC TMCOLAC
  50. -INC SMLOBJE
  51.  
  52.       SEGMENT/ITBBE1/( ITABE1(NN))
  53.       SEGMENT/ITBBE2/( ITABE2(NN))
  54.       segment itbbc2
  55.        character*4 itabc2(nn)
  56.       endsegment
  57.       SEGMENT/ITBBM1/( ITABM1(NM))
  58.       segment itbbc1
  59.        character*4 itabc1(nm)
  60.       endsegment
  61.       SEGMENT/ITBBM2/( ITABM2(NM2))
  62.       segment itbbc3
  63.        character*4 itabc3(nm2)
  64.       endsegment
  65.       SEGMENT/ITBBM3/( ITABM3(NM2))
  66.       segment itbbc4
  67.        character*4 itabc4(nm2)
  68.       endsegment
  69.       SEGMENT/ITBBM4/( ITABM4(NM2))
  70.       segment itbbc5
  71.        character*4 itabc5(nm2)
  72.       endsegment
  73.       SEGMENT/ITABR1/( TABR1(L)*D)
  74.       SEGMENT ITAMOT
  75.       CHARACTER*(NN) ITAMO
  76.       INTEGER ICOTA(NNN)
  77.       ENDSEGMENT
  78.       segment xmaaux
  79.        real*8 reaux(laux,nelrig)
  80.       endsegment
  81.  
  82. C
  83.       CHARACTER*(8) ITYPE,ITYPO
  84.       CHARACTER*512 CHA1
  85.       CHARACTER*72 LABEL
  86.       REAL*8 XRA
  87.       LOGICAL LIRA
  88.       DIMENSION ILENA(30)
  89.       DIMENSION IPV(2)
  90.       real*4 densi4
  91. C---
  92.       DATA NIVEAU /2/
  93. C======================================================================
  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. C
  109.       SEGACT ICOLAC
  110.       NITLAC=ICOLA(/1)
  111.       IF(IPSAUV.NE.0) GOTO 7654
  112. C
  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.                  if (abs(re(i,j,k)-re(j,i,k)).gt.
  564.      >            (abs(re(i,j,k))+abs(re(j,i,k)))*xzprec+xpetit)
  565.      >             call erreur(969)
  566.                 enddo
  567.                 ip=ip+j
  568.                enddo
  569.                if (ip.ne.laux) call erreur(5)
  570.               enddo
  571.               call ecdifr(iosau,ip*nelrig,reaux,iform)
  572.               segsup xmaaux
  573.               else
  574. *  cas general on sauve tout
  575.               CALL ECDIFR(IOSAU,lval,re,IFORM)
  576.               endif
  577.               segdes xmatri
  578.  2300    CONTINUE
  579.          GOTO 1098
  580. C     ***************************** MJONCT *****************************
  581.  6014    CONTINUE
  582.          CALL WRJONC (IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  583.          GOTO 1098
  584. C     ***************************** MATTAC *****************************
  585.  6015    CONTINUE
  586.          CALL WRATTA (IOSAU,ITLACC,IMAX1,IRETOU,IFORM,IDEB)
  587.          GOTO 1098
  588. C     ***************************** MMATRI *****************************
  589.  6016    CONTINUE
  590.          CALL WRMMAT (IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  591.          GOTO 1098
  592. C     *********************MDEFOR***********************************
  593.  6017    CONTINUE
  594.          DO 2700 IEL=IDEB,IMAX1
  595.             MDEFOR=ITLAC(IEL)
  596.             SEGACT MDEFOR
  597.             NDEF=IELDEF(/1)
  598.             ILENA(1)= NDEF
  599.             ITOTO   = 1
  600.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  601.             CALL ECDIFR(IOSAU,NDEF,AMPL,IFORM)
  602.             NN=7*NDEF
  603.             SEGINI ITBBE1
  604.             CALL JDANSI (ITABE1(1),       IELDEF(1),NDEF)
  605.             CALL JDANSI (ITABE1(NDEF+1),  ICHDEF(1),NDEF)
  606.             CALL JDANSI (ITABE1(2*NDEF+1),JCOUL(1),NDEF)
  607.             CALL JDANSI (ITABE1(3*NDEF+1),MTVECT(1),NDEF)
  608.             CALL JDANSI (ITABE1(4*NDEF+1),MDCHP(1),NDEF)
  609.             CALL JDANSI (ITABE1(5*NDEF+1),MDCHEL(1),NDEF)
  610.             CALL JDANSI (ITABE1(6*NDEF+1),MDMODE(1),NDEF)
  611.             CALL ECDIFE (IOSAU,NN,ITABE1,IFORM)
  612.             SEGSUP ITBBE1
  613. C
  614.             SEGDES MDEFOR
  615.  2700    CONTINUE
  616.          GOTO 1098
  617. C     ***************************MLREEL******************************
  618.  6018    CONTINUE
  619.          DO 2800 IEL=IDEB,IMAX1
  620.             MLREEL=ITLAC(IEL)
  621.             SEGACT MLREEL
  622.             L=PROG(/1)
  623.             ILENA(1)=L
  624.             ITOTO=1
  625.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  626.             CALL ECDIFR(IOSAU,L,PROG,IFORM)
  627.             SEGDES MLREEL
  628.  2800    CONTINUE
  629.          GOTO 1098
  630. C     *****************************MLENTI***************************
  631.  6019    CONTINUE
  632.          DO 2900 IEL=IDEB,IMAX1
  633.             MLENTI=ITLAC(IEL)
  634.             SEGACT MLENTI
  635.             L=LECT(/1)
  636.             ILENA(1)=L
  637.             ITOTO=1
  638.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  639.             CALL ECDIEE(IOSAU,L,LECT,IFORM)
  640.             SEGDES MLENTI
  641.  2900    CONTINUE
  642.          GOTO 1098
  643. C     ****************************MCHARG*****************************
  644.  6020    CONTINUE
  645.          NN=0
  646.          NM=0
  647.          NM2=0
  648.          SEGINI ITBBM1,itbbc1
  649.          SEGINI ITBBM2,itbbc3
  650.          SEGINI ITBBM3,itbbc4
  651.          SEGINI ITBBM4,itbbc5
  652.          SEGINI ITBBE1
  653.          SEGINI ITBBE2,itbbc2
  654.          DO 3000 IEL=IDEB,IMAX1
  655.             IF(IONIVE.LE.6) THEN
  656.                MCHARG=ITLAC(IEL)
  657.                SEGACT MCHARG*mod
  658.                N=KCHARG(/1)
  659.                ILENA(1)=N
  660.                ITOTO=1
  661.                CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  662.                NM=2*N
  663.                SEGADJ ITBBM1,itbbc1
  664.                NN=3*N
  665.                SEGADJ ITBBE1
  666.                DO 3001 I=1,N
  667.                   ICHARG=KCHARG(I)
  668.                   SEGACT ICHARG*mod
  669.                   IF(CHATYP.NE.'CHPOINT ') THEN
  670.  
  671. *---- cas du nouveau chargement . Incompatible avec niveau 6 ----
  672.  
  673.                      CALL ERREUR(691)
  674.                      GOTO 1099
  675.                   ENDIF
  676.                   I2=2*I
  677.                   I3=3*I
  678.                   if (ichar(chanat(i)(1:1)).eq.0) chanat(i)=' '
  679.                   READ (CHANAT(I),FMT='(2A4)') ITABM1(I2-1),ITABM1(I2)
  680.                   itabc1(i2-1)=chanat(i)(1:4)
  681.                   itabc1(i2)=chanat(i)(5:8)
  682.                   ITABE1(I3-2)=ICHPO1
  683.                   ITABE1(I3-1)=ICHPO2
  684.                   ITABE1(I3  )=ICHPO3
  685.                   SEGDES ICHARG
  686.  3001          CONTINUE
  687.                if (iform.ne.2) CALL ECDIFM(IOSAU,NM,ITABM1,IFORM)
  688.                if (iform.eq.2) then
  689.                 ios=IXDRSTRING( ixdrw, itabc1(1)(1:nm*4))
  690.                 dimatt = dimatt + nm
  691.                endif
  692.                CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  693.                SEGDES MCHARG
  694.             ELSE IF(IONIVE.GE.7.AND.IONIVE.LE.10) THEN
  695.                MCHARG=ITLAC(IEL)
  696.                SEGACT MCHARG*mod
  697.                N=KCHARG(/1)
  698.                ILENA(1)=N
  699.                ITOTO=1
  700.                CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  701. c            CALL ECDIFM(IOSAU,NM,CHANAT,IFORM)
  702. c            CALL ECDIFM(IOSAU,N ,CHANOM,IFORM)
  703.                NN=2*N
  704.                SEGADJ ITBBE2,itbbc2
  705.                NM=2*N
  706.                SEGADJ ITBBM1,itbbc1
  707.                NM2=N
  708.                SEGADJ ITBBM2,itbbc3
  709.                NN=3*N
  710.                SEGADJ ITBBE1
  711.                DO 3002 I=1,N
  712.                   ICHARG=KCHARG(I)
  713.                   SEGACT ICHARG*mod
  714.                   I2=2*I
  715.                   I3=3*I
  716.                   if (ichar(chatyp(1:1)).eq.0) chatyp=' '
  717.                   READ (CHATYP,FMT='(2A4)') ITABM1(I2-1),ITABM1(I2)
  718.                   itabc1(i2-1)=chatyp(1:4)
  719.                   itabc1(i2)=chatyp(5:8)
  720.                   if (ichar(chanat(i)(1:1)).eq.0) chanat(i)=' '
  721.                   READ (CHANAT(I),FMT='(2A4)') ITABE2(I2-1),ITABE2(I2)
  722.                   itabc2(i2-1)=chanat(i)(1:4)
  723.                   itabc2(i2)=chanat(i)(5:8)
  724.                   if (ichar(chanom(i)(1:1)).eq.0) chanom(i)=' '
  725.                   READ (CHANOM(I),FMT='(1A4)') ITABM2(I)
  726.                   itabc3(i)=chanom(i)
  727.                   ITABE1(I3-2)=ICHPO1
  728.                   ITABE1(I3-1)=ICHPO2
  729.                   ITABE1(I3)=ICHPO3
  730.                   SEGDES ICHARG
  731.  3002          CONTINUE
  732.                if (iform.ne.2) CALL ECDIFM(IOSAU,2*N,ITABE2,IFORM)
  733.                if (iform.eq.2)ios=IXDRSTRING( ixdrw, itabc2(1)(1:4*2*n))
  734.                if (iform.ne.2) CALL ECDIFM(IOSAU,N,ITABM2,IFORM)
  735.                if (iform.eq.2) ios=IXDRSTRING( ixdrw, itabc3(1)(1:4*n))
  736.                if (iform.ne.2) CALL ECDIFM(IOSAU,NM,ITABM1,IFORM)
  737.                if (iform.eq.2) ios=IXDRSTRING( ixdrw, itabc1(1)(1:4*nm))
  738.                dimatt = dimatt + (3*n) +nm
  739.                CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  740.                SEGDES MCHARG
  741.             ELSE
  742.                MCHARG=ITLAC(IEL)
  743.                SEGACT MCHARG*mod
  744.                N=KCHARG(/1)
  745.                ILENA(1)=N
  746.                ITOTO=1
  747.                CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  748.                NN=2*N
  749.                SEGADJ ITBBE2,itbbc2
  750.                NM=2*N
  751.                SEGADJ ITBBM1,itbbc1
  752.                NM2=N
  753.                SEGADJ ITBBM2,itbbc3
  754.                SEGADJ ITBBM3,itbbc4
  755.                SEGADJ ITBBM4,itbbc5
  756.                NN=7*N
  757.                SEGADJ ITBBE1
  758.                DO 3003 I=1,N
  759.                   ICHARG=KCHARG(I)
  760.                   SEGACT ICHARG*mod
  761.                   I2=2*I
  762.                   I3=7*I
  763.                   if (ichar(chatyp(1:1)).eq.0) chatyp=' '
  764.                   READ (CHATYP,FMT='(2A4)') ITABM1(I2-1),ITABM1(I2)
  765.                   itabc1(i2-1)=chatyp(1:4)
  766.                   itabc1(i2)=chatyp(5:8)
  767.                   if (ichar(chanat(i)(1:1)).eq.0) chanat(i)=' '
  768.                   READ (CHANAT(I),FMT='(2A4)') ITABE2(I2-1),ITABE2(I2)
  769.                   itabc2(i2-1)=chanat(i)(1:4)
  770.                   itabc2(i2)=chanat(i)(5:8)
  771.                   if (ichar(chanom(i)(1:1)).eq.0) chanom(i)=' '
  772.                   READ (CHANOM(I),FMT='(1A4)') ITABM2(I)
  773.                   itabc3(i)=chanom(i)
  774.                   if (ichar(chamob(i)(1:1)).eq.0) chamob(i)=' '
  775.                   READ (CHAMOB(I),FMT='(1A4)') ITABM3(I)
  776.                   itabc4(i)=chamob(i)
  777.                   if (ichar(chalie(i)(1:1)).eq.0) chalie(i)=' '
  778.                   READ (CHALIE(I),FMT='(1A4)') ITABM4(I)
  779.                   itabc5(i)=chalie(i)
  780.                   ITABE1(I3-6)=ICHPO1
  781.                   ITABE1(I3-5)=ICHPO2
  782.                   ITABE1(I3-4)=ICHPO3
  783.                   ITABE1(I3-3)=ICHPO4
  784.                   ITABE1(I3-2)=ICHPO5
  785.                   ITABE1(I3-1)=ICHPO6
  786.                   ITABE1(I3)  =ICHPO7
  787.                   SEGDES ICHARG
  788.  3003          CONTINUE
  789.                if (iform.ne.2) CALL ECDIFM(IOSAU,2*N,ITABE2,IFORM)
  790.                if (iform.eq.2)ios=IXDRSTRING( ixdrw, itabc2(1)(1:4*2*n))
  791.                if (iform.ne.2) CALL ECDIFM(IOSAU,N,ITABM2,IFORM)
  792.                if (iform.eq.2) ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*n))
  793.                if (iform.ne.2) CALL ECDIFM(IOSAU,N,ITABM3,IFORM)
  794.                if (iform.eq.2) ios=IXDRSTRING( ixdrw,itabc4(1)(1:4*n))
  795.                if (iform.ne.2) CALL ECDIFM(IOSAU,N,ITABM4,IFORM)
  796.                if (iform.eq.2) ios=IXDRSTRING( ixdrw,itabc5(1)(1:4*n))
  797.                if (iform.ne.2) CALL ECDIFM(IOSAU,NM,ITABM1,IFORM)
  798.                if (iform.eq.2) ios=IXDRSTRING( ixdrw,itabc1(1)(1:4*nm))
  799.                dimatt = dimatt + (5*n) +nm
  800.                CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  801.                SEGDES MCHARG
  802.             ENDIF
  803.  3000    CONTINUE
  804.          SEGSUP ITBBE1,ITBBM1,itbbc1,ITBBE2,itbbc2,ITBBM2,itbbc3,
  805.      >          ITBBM3,itbbc4,ITBBM4,itbbc5
  806.  
  807.          GOTO 1098
  808. C     ****************************        **************************
  809.  6021    CONTINUE
  810.          GOTO 1098
  811. C     *****************************MEVOLL***************************
  812.  6022    CONTINUE
  813.          NN=0
  814.          NM=0
  815.          NM2=20
  816.          SEGINI ITBBM2,itbbc3
  817.          SEGINI ITBBE2,itbbc2
  818.          SEGINI ITBBE1,ITBBM1,itbbc1
  819.          LDECA=7
  820.          IF(IONIVE.GE.3) LDECA=11
  821.          LDECA2=18
  822.          DO 3200 IEL=IDEB,IMAX1
  823.             MEVOLL=ITLAC(IEL)
  824.             SEGACT MEVOLL*mod
  825.             N=IEVOLL(/1)
  826.             ILENA(1)=N
  827.             ITOTO=1
  828.             NM2=20
  829.             SEGADJ ITBBM2,itbbc3
  830.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  831.             READ (ITYEVO,FMT='(2A4)') ITABM2(1),ITABM2(2)
  832.             itabc3(1)=ityevo(1:4)
  833.             itabc3(2)=ityevo(5:8)
  834.             if (ichar(ievtex(1:1)).eq.0) ievtex=' '
  835.             READ (IEVTEX,FMT='(18A4)') (ITABM2(2+JPV),JPV=1,18)
  836.             do jpv=1,18
  837.              itabc3(2+jpv)=ievtex(1+(jpv-1)*4:jpv*4)
  838.             enddo
  839.             if (iform.ne.2) CALL ECDIFM (IOSAU,NM2,ITABM2,IFORM)
  840.             if (iform.eq.2) then
  841.              ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*nm2))
  842.              dimatt = dimatt + nm2
  843.             endif
  844.             NN=3*N
  845.             SEGADJ ITBBE1
  846.             NM=LDECA*N
  847.             SEGADJ ITBBM1,itbbc1
  848.             NM2=LDECA2*N
  849.             SEGADJ ITBBM2,itbbc3
  850. C        LOOP SUR LES KEVOL-
  851.             DO 3201 IN=1,N
  852.                KEVOLL=IEVOLL(IN)
  853.                SEGACT KEVOLL*mod
  854.                I4=3*IN
  855.                ITABE1(I4-2)= IPROGX
  856.                ITABE1(I4-1)= IPROGY
  857.                ITABE1(I4)= NUMEVX
  858.                I7=LDECA*(IN-1)
  859.                I8=LDECA2*(IN-1)
  860.                if (ichar(nomevx(1:1)).eq.0) nomevx=' '
  861.                READ (NOMEVX,FMT='(3A4)') (ITABM1(I7+I),I=1,3)
  862.                itabc1(i7+1)=nomevx(1:4)
  863.                itabc1(i7+2)=nomevx(5:8)
  864.                itabc1(i7+3)=nomevx(9:12)
  865.                if (ichar(nomevy(1:1)).eq.0) nomevy=' '
  866.                READ (NOMEVY,FMT='(3A4)') (ITABM1(I7+I+3),I=1,3)
  867.                itabc1(i7+3+1)=nomevy(1:4)
  868.                itabc1(i7+3+2)=nomevy(5:8)
  869.                itabc1(i7+3+3)=nomevy(9:12)
  870.                if (ichar(numevy(1:1)).eq.0) numevy=' '
  871.                READ (NUMEVY,FMT='(A4)') ITABM1(I7 +7)
  872.                itabc1(i7+7)=numevy
  873.                IF(IONIVE.GE.3) THEN
  874.                   if (ichar(typx(1:1)).eq.0) typx=' '
  875.                   READ (TYPX,FMT='(2A4)') (ITABM1(I7+7+I),I=1,2)
  876.                   itabc1(i7+7+1)=typx(1:4)
  877.                   itabc1(i7+7+2)=typx(5:8)
  878.                   if (ichar(typy(1:1)).eq.0) typy=' '
  879.                   READ (TYPY,FMT='(2A4)') (ITABM1(I7+9+I),I=1,2)
  880.                   itabc1(i7+9+1)=typy(1:4)
  881.                   itabc1(i7+9+2)=typy(5:8)
  882.                   if (ichar(kevtex(1:1)).eq.0) kevtex=' '
  883.                   READ(KEVTEX,FMT='(18A4)')(ITABM2(I8+JPV),JPV=1,18)
  884.                   do jpv=1,18
  885.                    itabc3(i8+jpv)=kevtex(1+(jpv-1)*4:4*jpv)
  886.                   enddo
  887.                ENDIF
  888.                SEGDES KEVOLL
  889.  3201       CONTINUE
  890.             SEGDES MEVOLL
  891.             NN=3*N
  892.             CALL ECDIFE(IOSAU,NN,ITABE1,IFORM)
  893.             NN=LDECA*N
  894.             if (iform.ne.2) CALL ECDIFM(IOSAU,NN,ITABM1,IFORM)
  895.             if (iform.eq.2) then
  896.              ios=IXDRSTRING( ixdrw,itabc1(1)(1:4*nn))
  897.              dimatt = dimatt + nn
  898.             endif
  899.             IF(IONIVE.GE.3) then
  900.              if (iform.ne.2) CALL ECDIFM (IOSAU,NM2,ITABM2,IFORM)
  901.              if (iform.eq.2) then
  902.               ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*nm2))
  903.               dimatt = dimatt + nm2
  904.              endif
  905.             endif
  906.  3200    CONTINUE
  907.          SEGSUP ITBBM2,itbbc3
  908.          SEGSUP ITBBE2,itbbc2
  909.          SEGSUP ITBBE1,ITBBM1,itbbc1
  910.          GOTO 1098
  911. C     **********************SUPERELE************************************
  912.  6023    CONTINUE
  913.          NTOTO=6
  914.          ITOTO=1
  915.          DO 230 IEL=IDEB,IMAX1
  916.             MSUPER=ITLAC(IEL)
  917.             SEGACT MSUPER
  918.             ILENA(1)=NTOTO
  919.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  920.             ILENA(1)=MRIGTO
  921.             ILENA(2)=MSUPEL
  922.             ILENA(3)=MSURAI
  923.             ILENA(4)=MBLOQU
  924.             ILENA(5)=MSUMAS
  925. C *** On ecrit MCROUT pour memoire mais il ne sera pas sauve (MMATRI)
  926.             ILENA(6)=MCROUT
  927.             CALL ECDIFE (IOSAU,NTOTO,ILENA,IFORM)
  928.             SEGDES MSUPER
  929.  230     CONTINUE
  930.          GOTO 1098
  931. C     ************************* LOGIQUE  ***************************
  932.  6024    CONTINUE
  933.          ITOTO=1
  934.          IVLON=IMAX1-IDEB+1
  935.          ILENA(1)=IVLON
  936.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  937.          NN=IVLON
  938.          SEGINI ITBBE1
  939.          DO 240 I=1,IVLON
  940.             IVA=ITLAC(I+IDEB-1)
  941.             CALL QUEVAL(IVA,'LOGIQUE ',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  942.             IF(LIRA)ITOTO=1
  943.             IF(.NOT.LIRA)ITOTO=0
  944.             ITABE1(I)=ITOTO
  945.  240     CONTINUE
  946.          CALL ECDIFE( IOSAU,IVLON,ITABE1(1),IFORM)
  947.          SEGSUP ITBBE1
  948.          GOTO 1098
  949. C     ************************* FLOTTANT ***************************
  950.  6025    CONTINUE
  951.          ITOTO=1
  952.          IVLON=IMAX1-IDEB+1
  953.          ILENA(1)=IVLON
  954.          L=IVLON
  955.          SEGINI ITABR1
  956.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  957.          DO 250 I=1,IVLON
  958.             IVA=ITLAC(I+IDEB-1)
  959.             CALL QUEVAL(IVA,'FLOTTANT',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  960.             TABR1(I)=XRA
  961.  250     CONTINUE
  962.          CALL ECDIFR(IOSAU,IVLON,TABR1,IFORM)
  963.          SEGSUP ITABR1
  964.          GOTO 1098
  965. C     **************************** ENTIER***************************
  966.  6026    CONTINUE
  967.          IVLON=IMAX1-IDEB+1
  968.          ILENA(1)=IVLON
  969.          ITOTO=1
  970.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  971.          NN=IVLON
  972.          SEGINI ITBBE1
  973. *        write (6,*) ' wrpil ideb ivlon itlacc ',ideb,ivlon,itlacc
  974.          DO 260 I=1,IVLON
  975.             IVA=ITLAC(I+IDEB-1)
  976.             CALL QUEVAL(IVA,'ENTIER  ',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  977.             ITABE1(I)=IVALIN
  978.  260     CONTINUE
  979. *        write (6,*) ' wrpil entiers ',(itabe1(i),i=1,ivlon)
  980.          CALL ECDIEE( IOSAU,IVLON,ITABE1(1),IFORM)
  981.          GOTO 1098
  982. C     **************************** MOT   ***************************
  983.  6027    CONTINUE
  984.          NN=0
  985.          NNN=0
  986.          SEGINI ITAMOT
  987.          IVLON=IMAX1-IDEB+1
  988.          DO 270 I=1,IVLON
  989.             IVA=ITLAC(I+IDEB-1)
  990. C  CHA1 EST UNE CHAINE DE 512 CARACTERES
  991.             CALL QUEVAL(IVA,'MOT     ',IRETP,IVALIN,XRA,CHA1,LIRA,IOBVA)
  992.             NN1=NN
  993.             NN=NN+IVALIN
  994.             NNN=NNN+1
  995.             SEGADJ ITAMOT
  996.             ICOTA(NNN)=NN
  997.             ITAMO(1+NN1:IVALIN+NN1)=CHA1(1:IVALIN)
  998.  270     CONTINUE
  999.          ILENA(1)=NN
  1000.          ITOTO=2
  1001.          ILENA(2)=IVLON
  1002.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1003.          CALL ECDIFC( IOSAU,ITAMO,IFORM)
  1004.          CALL ECDIFE( IOSAU,IVLON,ICOTA,IFORM)
  1005.          SEGSUP ITAMOT
  1006.          GOTO 1098
  1007. C     ****************************TEXTE    *************************
  1008.  6028    CONTINUE
  1009.          DO 2928 IEL=IDEB,IMAX1
  1010.             MTEXTE=ITLAC(IEL)
  1011.             SEGACT MTEXTE
  1012. CCCC  L       =(NCART+3)/4
  1013.             L=NCART
  1014.             ITOTO=1
  1015.             ILENA(1)=L
  1016.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1017.             CALL ECDIFC( IOSAU,MTEXT,IFORM)
  1018.             SEGDES MTEXTE
  1019.  2928    CONTINUE
  1020.          GOTO 1098
  1021. C     ****************************LISTMOTS *************************
  1022.  6029    CONTINUE
  1023.          DO 2929 IEL=IDEB,IMAX1
  1024.             MLMOTS=ITLAC(IEL)
  1025.             SEGACT MLMOTS
  1026.             ILENA(1)=MOTS(/1)
  1027.             ILENA(2)=MOTS(/2)
  1028.             ITOTO=2
  1029.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1030.             NNA=ILENA(1)
  1031.             NNN = 0
  1032.             NN = ILENA(1)*ILENA(2)
  1033.             SEGINI ITAMOT
  1034.             DO 2930 IMM=1,ILENA(2)
  1035.                ITAMO((IMM-1)*NNA+1:IMM*NNA)=MOTS(IMM)
  1036.  2930       CONTINUE
  1037.             CALL ECDIFC( IOSAU,ITAMO,IFORM)
  1038.             SEGDES MLMOTS
  1039.             SEGSUP ITAMOT
  1040.  2929    CONTINUE
  1041.          GOTO 1098
  1042. C     **************************** VECTEUR**************************
  1043.  6030    CONTINUE
  1044.          DO 300 IEL=IDEB,IMAX1
  1045.             MVECTE =ITLAC(IEL)
  1046.             CALL WRVECT (MVECTE,IOSAU,IRETOU,IFORM)
  1047.  300     CONTINUE
  1048.          GOTO 1098
  1049. C     ************************* VECTD    ***************************
  1050.  6031    CONTINUE
  1051.          DO 310 IEL=IDEB,IMAX1
  1052.             MVECTD=ITLAC(IEL)
  1053.             SEGACT MVECTD
  1054.             INC=VECTBB(/1)
  1055.             ILENA(1)=INC
  1056.             ITOTO=1
  1057.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1058.             CALL ECDIFR(IOSAU,INC,VECTBB,IFORM)
  1059.             SEGDES MVECTD
  1060.  310     CONTINUE
  1061.          GOTO 1098
  1062. C     ************************* POINT    ***************************
  1063.  6032    CONTINUE
  1064. * on sauve tout le itlac car numerotation a pu changer
  1065.          ILENA(1)=IMAX1
  1066.          ITOTO=1
  1067.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1068.          CALL ECDIFE( IOSAU,IMAX1,ITLAC,IFORM)
  1069.          GOTO 1098
  1070. C     ************************* CONFIG   ***************************
  1071.  6033    CONTINUE
  1072.          CALL WRCONF(IOSAU,ITLACC,IMAX1,IFORM,IDEB,IDIM,MCOORD)
  1073.          GOTO 1098
  1074. C     ******************* MLCHPO ************************************
  1075.  6034    CONTINUE
  1076.          DO 340 IEL=IDEB,IMAX1
  1077.             MLCHPO=ITLAC(IEL)
  1078.             SEGACT MLCHPO
  1079.             N1=ICHPOI(/1)
  1080.             ILENA(1)=N1
  1081.             ITOTO=1
  1082.             CALL ECDIFE (IOSAU,ITOTO,ILENA,IFORM)
  1083.             CALL ECDIFE(IOSAU,N1,ICHPOI,IFORM)
  1084.             SEGDES MLCHPO
  1085.  340     CONTINUE
  1086.          GOTO 1098
  1087. C     ****************************MBASEM*****************************
  1088.  6035    CONTINUE
  1089.          NN=0
  1090.          DO 3500 IEL=IDEB,IMAX1
  1091.             MBASEM=ITLAC(IEL)
  1092.             SEGACT MBASEM
  1093.             N=LISBAS(/1)
  1094.             ILENA(1)=N
  1095.             ITOTO=1
  1096.             CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1097.             ITOTO=1
  1098.             DO 3501 I=1,N
  1099.                MSOBAS=LISBAS(I)
  1100.                SEGACT MSOBAS
  1101.                NIBST=IBSTRM(/1)
  1102.                ILENA(1)=NIBST
  1103.                CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1104.                CALL ECDIFE(IOSAU,NIBST,IBSTRM(1),IFORM)
  1105.                SEGDES MSOBAS
  1106.  3501       CONTINUE
  1107.             SEGDES MBASEM
  1108.  3500    CONTINUE
  1109.          GOTO 1098
  1110. C     **********************PROCEDUR************************************
  1111.  6036    CONTINUE
  1112.          GOTO 1098
  1113. C     **********************BLOC****************************************
  1114.  6037    CONTINUE
  1115.          GOTO 1098
  1116. C     *********************** MODELE MMODEL ****************************
  1117.  6038    CONTINUE
  1118.          CALL WRMODL(IOSAU,ITLACC,IMAX1,IFORM,IONIVE,IDEB)
  1119.          GOTO 1098
  1120. C     *********************** MCHAML ***********************************
  1121.  6039    CONTINUE
  1122.          CALL WRCHAM(IOSAU,ITLACC,IMAX1,IFORM,IONIVE,IDEB)
  1123.          GOTO 1098
  1124. C     **************************  MINTE  *******************************
  1125.  6040    CONTINUE
  1126.          DO 2840 IEL=IDEB,IMAX1
  1127.             MINTE=ITLAC(IEL)
  1128.             SEGACT MINTE
  1129.             NBNO  =SHPTOT(/2)
  1130.             NBPGAU=SHPTOT(/3)
  1131.             L=NBPGAU*4+6*NBPGAU*NBNO
  1132.             ILENA(1)= NBNO
  1133.             ILENA(2)= NBPGAU
  1134.             ITOTO=2
  1135.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  1136.             SEGINI ITABR1
  1137.             I=0
  1138.             DO 2841 IC=1,NBPGAU
  1139.                I=I+1
  1140.                TABR1(I)=POIGAU(IC)
  1141.                I=I+1
  1142.                TABR1(I)=QSIGAU(IC)
  1143.                I=I+1
  1144.                TABR1(I)=ETAGAU(IC)
  1145.                I=I+1
  1146.                TABR1(I)=DZEGAU(IC)
  1147.                DO 2842 IB=1,NBNO
  1148.                   DO 2843 IA=1,6
  1149.                      I=I+1
  1150.                      TABR1(I)=SHPTOT(IA,IB,IC)
  1151.  2843             CONTINUE
  1152.  2842          CONTINUE
  1153.  2841       CONTINUE
  1154.             CALL ECDIFR (IOSAU,L,TABR1,IFORM)
  1155.             SEGSUP ITABR1
  1156.             SEGDES MINTE
  1157.  2840    CONTINUE
  1158.          GOTO 1098
  1159. C     *********************** NUAGE ***************************
  1160.  6041    CONTINUE
  1161.          CALL WRNUAG(IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  1162.          GOTO 1098
  1163. C     ********************** MATRAK *********************************
  1164.  6042    CONTINUE
  1165.          CALL WRMTAK (IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  1166.          GOTO 1098
  1167. C     ********************** MATRIK *********************************
  1168.  6043    CONTINUE
  1169.          CALL WRMTIK(IOSAU,ITLACC,IMAX1,IFORM,IDEB)
  1170.          GOTO 1098
  1171. C     *****************************METHODE *********************
  1172.  6045    CONTINUE
  1173.          IVLON=IMAX1-IDEB+1
  1174. C      APPELE PAR WRPI
  1175.          ILENA(1)=IVLON
  1176.          ITOTO=1
  1177.          CALL ECDIFE( IOSAU,ITOTO,ILENA,IFORM)
  1178.          CALL ECDIFE(IOSAU,IVLON,ITLAC(IDEB),IFORM)
  1179.          GOTO 1098
  1180. C     ****************************************************************
  1181. C     *********************** IELVAL ***********************************
  1182.  6048    CONTINUE
  1183.          if (ionive.ge.20)
  1184.      >    CALL WRIELV(IOSAU,ITLACC,IMAX1,IFORM,IONIVE,IDEB)
  1185.          GOTO 1098
  1186.  
  1187. C     *********************** ANNOTATI *********************************
  1188.  6049    CONTINUE
  1189.          GOTO 1098
  1190. C     *********************** LISTOBJE**********************************
  1191.  6050    CONTINUE
  1192.          DO 550 IEL=IDEB,IMAX1
  1193.             MLOBJE=ITLAC(IEL)
  1194.             IF (MLOBJE.EQ.0) GOTO 550
  1195.             SEGACT, MLOBJE
  1196.             N1=LISOBJ(/1)
  1197.             ITYPO = TYPOBJ
  1198. C           write(6,*) '**** ITYPO=',ITYPO
  1199.             ILENA(1)=N1
  1200.             ITOTO=1
  1201.             CALL ECDIFE(IOSAU,ITOTO,ILENA,IFORM)
  1202.             NM2 = 2
  1203.             SEGINI, ITBBM2,itbbc3
  1204.             READ (ITYPO,FMT='(2A4)') ITABM2(1),ITABM2(2)
  1205.             itabc3(1)=TYPOBJ(1:4)
  1206.             itabc3(2)=TYPOBJ(5:8)
  1207. C           write(6,*) '**** ITABM2=',ITABM2(1),ITABM2(2)
  1208.             if (iform.ne.2) CALL ECDIFM(IOSAU,NM2,ITABM2,IFORM)
  1209.             if (iform.eq.2) then
  1210.               ios=IXDRSTRING( ixdrw,itabc3(1)(1:4*nm2))
  1211.               dimatt = dimatt + nm2
  1212.             endif
  1213. C           write(6,*) '**** LISOBJ(1)=',LISOBJ(1)
  1214.             CALL ECDIFE(IOSAU,N1,LISOBJ,IFORM)
  1215.             SEGDES, MLOBJE
  1216.  550     CONTINUE
  1217.          GOTO 1098
  1218.  
  1219. C     ******************************************************************
  1220.  
  1221.  1098    CONTINUE
  1222.  
  1223. C     ********************** Fin de boucle IFILE **********************
  1224.  
  1225.  1099 CONTINUE
  1226. C
  1227. C     **********************MSOLUT: TRAITE EN DERNIER*****************
  1228. C
  1229.       IFILE=8
  1230.       ITLACC=KCOLA(IFILE)
  1231.       IMAX1=ITLAC(/1)
  1232.       IDEB=1
  1233.       IF(IPSAUV.NE.0) IDEB=KCOLAC(IFILE)+1
  1234.       IF(IMAX1.LT.IDEB) GOTO 2099
  1235.       ITYPE='        '
  1236.       CALL TYPFIL(ITYPE,IFILE)
  1237.       WRITE(IOIMP,801)IFILE,IMAX1,ITYPE
  1238.       IP1=ICOLA(IFILE)
  1239.       ITLACC=KCOLA(IFILE)
  1240. C
  1241.       CALL NOMMEF(IP1,IMAX1,IFILE,IFORM,IDEB,isilen)
  1242.       DO 1800 IEL=IDEB,IMAX1
  1243.          MSOLUT=ITLAC(IEL)
  1244. C*       IF (IONIVE.LE.2) CALL SOSOLF(ICOLAC,MSOLUT,IFORM)
  1245.          IF (IONIVE.GE.3) CALL WRSOLU(MSOLUT,IRETOU,IFORM)
  1246.  1800 CONTINUE
  1247. C     *****************************************************************
  1248.  2099 CONTINUE
  1249. C
  1250.       IQUOI=5
  1251.       CALL ECDES (IOSAU,IQUOI,IFORM)
  1252.       IF(IFORM.EQ.1)WRITE (IOSAU,772)LABEL
  1253.       IF(IFORM.EQ.0)WRITE (IOSAU)LABEL
  1254.       if (iform.eq.2) then
  1255.        ios=IXDRSTRING( ixdrw, label(1:72))
  1256.        dimatt = dimatt + 18
  1257.       else
  1258. *       sur certaines machines, la fermeture du fichier pouvait poser
  1259. *       probleme (buffer non ecrit avant de sortir de castem)
  1260.         CALL FLUSH(IOSAU)
  1261.       endif
  1262.       MOTERR=LABEL
  1263.       Call erreur(-345)
  1264.  772  FORMAT(A72)
  1265.       SEGDES ICOLAC
  1266.       RETURN
  1267.       END
  1268.  
  1269.  
  1270.  
  1271.  
  1272.  
  1273.  

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