Télécharger sauv.eso

Retour à la liste

Numérotation des lignes :

  1. C SAUV SOURCE PV 21/01/21 21:15:33 10862
  2. SUBROUTINE SAUV
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C DIRECTIVE SAUVER
  7. C ----------------
  8. C
  9. C SAUVER (FORMAT) OBJ1 ...OBJN ;
  10. C ($GEO)
  11. C BUT: SAUVEGARDE DES OBJETS NOMMES ET DE CEUX QU ILS
  12. C SOUS-TENDENT, SUR LE FICHIER IOSAU
  13. C IOSAU EST DEFINI PAR: OPTIO SAUV IOSAU ;
  14. C
  15. C
  16. C ON SAIT SAUVER LES OBJETS DONT LE TYPE EST CONTENU
  17. C DANS LE SP TYPFIL
  18. C
  19. C APPELLE TYPFIL CREPIL FILLLU FILLP1 FILLPI SORTRI FILLNO
  20. C MAJICO IMPPIL MAXP1 MAXP32 WRPIL RESTPI SUPPIL
  21. C SAVEPI PILOBJ
  22. C ECRIT PAR FARVACQUE
  23. C REPRIS PAR LENA
  24. C ---------------------------------------------------------------------
  25. C POUR SAUVER UN AUTRE TYPE IL FAUT INTERVENIR DANS TYPFIL:
  26. C RAJOUTER DANS IPOSSI LES DEUX MOTS ASSOCIES
  27. C INCREMENTER NPOSSI DE 2
  28. C VERIFIER QUE LA DIM DU TABLEAU IPOSSI EST GE NPOSSI
  29. C ET FAIRE LE TRAITEMENT DANS CHAQUE SP VIA LES GO TO
  30. C=======================================================================
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC CCNOYAU
  35. -INC TMLCHA8
  36. -INC TMCOLAC
  37. -INC SMCOORD
  38. -INC CCFXDR
  39. -INC CCASSIS
  40. C
  41. SEGMENT ISORTA
  42. CHARACTER*8 ISORTC(KS)
  43. INTEGER ISORTI(KS)
  44. ENDSEGMENT
  45. external long
  46. DIMENSION ITYPE (2)
  47. CHARACTER*(8) CTYP
  48. CHARACTER*4 MOFORM(3)
  49. CHARACTER*72 LABEL
  50. SAVE ILABAU
  51. DATA ILABAU/0/
  52. DATA MOFORM /'FORM','LABE','MUET'/
  53. iun=1
  54. C=======================================================================
  55. C ----ON REGARDE S IL S AGIT D UN SAUV AVEC OU SANS FORMAT-----------
  56. ICOLAC=0
  57. IFORM=0
  58. ISILEN=0
  59. LABEL=' '
  60. IAUT=1
  61. C * attention aux assistants ....
  62. if (NBESC.NE.0) then
  63. if (iimpi .eq. 1234)
  64. & write(ioimp,*) ' il faut bloquer les assistants'
  65. mestra=imestr
  66. SEGACT MESTRA*MOD
  67. if (iimpi .eq. 1234)
  68. & write(ioimp,*) ' assistants en attente'
  69. * on passe en mode force
  70. call ooofrc(1)
  71. * lodesl=.true.
  72. call setass(1)
  73. endif
  74. 46 CONTINUE
  75. CALL LIRMOT(MOFORM,3,IFURM,0)
  76. IF( IFURM.EQ.1) THEN
  77. IFORM=1
  78. if(isafor.ne.iform) then
  79. call erreur(21)
  80. return
  81. endif
  82. GO TO 46
  83. ELSEIF(IFURM.EQ.2) THEN
  84. CALL LIRCHA (LABEL,1,IRETOU)
  85. IF(IERR.NE.0) RETURN
  86. IAUT=0
  87. GO TO 46
  88. ELSEIF (IFURM.EQ.3) THEN
  89. ISILEN=1
  90. ENDIF
  91. LGEOM=0
  92. iform=isafor
  93. * write (6,*) ' iformx dans sauv ',iformx
  94. if (iformx.eq.2) iform=2
  95. IF(IAUT.EQ.1) THEN
  96. ILABAU=ILABAU+1
  97. LABEL='LABEL_AUTOMATIQUE_'
  98. IF(ilabau.lt.10) then
  99. WRITE(LABEL(19:19),FMT='(I1)') ILABAU
  100. ELSEIF(ilabau.lt.100) then
  101. WRITE(LABEL(19:20),FMT='(I2)') ILABAU
  102. ELSEIF(ilabau.lt.1000) then
  103. WRITE(LABEL(19:21),FMT='(I3)') ILABAU
  104. ELSEIF(ilabau.lt.10000) then
  105. WRITE(LABEL(19:22),FMT='(I4)') ILABAU
  106. ELSE
  107. WRITE(LABEL(19:23),FMT='(I5)') ILABAU
  108. ENDIF
  109. ENDIF
  110. IF (IIMPI.EQ.5) WRITE(IOIMP,799)
  111. 799 FORMAT(' LECTURE DES OBJETS A SAUVER')
  112.  
  113. KS=0
  114. SEGINI ISORTA
  115.  
  116. 1 CONTINUE
  117. CTYP=' '
  118. CALL QUETYP(CTYP,0,IRETOU)
  119. IF(IRETOU.NE.1) GO TO 100
  120.  
  121. CALL LIROBJ(CTYP,IRET,0,IRETOU)
  122. C------- ON CONTROLE LA VALIDITE DU TYPE DEMANDE
  123. K=0
  124. CALL TYPFIL (CTYP,K)
  125. IF (K.LT.0) THEN
  126. C---------- ON NE SAIT PAS SORTIR UN OBJET DE CE TYPE
  127. MOTERR(1:8)=CTYP
  128. CALL ERREUR(242)
  129. GO TO 5000
  130. ENDIF
  131.  
  132. C------- LE TYPE EST OK
  133. KS=ISORTI(/1)+1
  134. SEGADJ ISORTA
  135. ISORTC(KS)=CTYP
  136. ISORTI(KS)=IRET
  137. GO TO 1
  138.  
  139. C---- ON A EXPLORE TOUTES LES DEMANDES
  140. 100 CONTINUE
  141. LOBJ=ISORTI(/1)
  142. IF (LOBJ.EQ.0) THEN
  143. SEGDES ISORTA
  144. ELSE
  145. IF (IIMPI.EQ.5) WRITE (IOIMP,821) LOBJ
  146. 821 FORMAT(' NOMBRE D OBJETS A SAUVER: ',I5)
  147. ENDIF
  148.  
  149. C---- LE NIVEAU 22 A INTRODUIT LES NOMS DE PLUS DE 8 CARACTERES
  150. IF (IONIVE.LT.22) THEN
  151. INTERR(1)=IONIVE
  152. CALL ERREUR(-359)
  153. ENDIF
  154.  
  155. C -------------------------------------------------------
  156. C **** A PARTIR DES OBJETS DE ISORTA,ON REMPLIT LES PILES
  157. C **** ICOLAC EST INITIALISEE DANS CREPIL
  158.  
  159. C---- Cet appel a TYPFIL renvoie -NPOSSI dans K
  160. CTYP=' '
  161. K=-1
  162. CALL TYPFIL( CTYP,K)
  163. C---- NITLAC = nombre de types 'sauvegardables'
  164. NITLAC=-K
  165. IF(IPSAUV.NE.0) THEN
  166. ICOLAC=IPSAUV
  167. CALL CREPI0(ICOLAC)
  168. segact icolac*mod
  169. iform=ifform
  170. ELSE
  171. CALL CREPIL(ICOLAC,NITLAC)
  172. segact icolac*mod
  173. IFFORM=IFORM
  174. ENDIF
  175. C---- Cet appel cree un 1 segment ICOLAC(NITLAC) ainsi que NITLAC :
  176. C - segments ITLACC dont les adresses sont stockees dans KCOLA
  177. C (faisant partie de ICOLAC)
  178. C - segments ISGTR(KS) avec KS=0 dont les adresses sont stockees
  179. C dans ICOLA (faisant partie de ICOLAC)
  180. C Les MCOLA et KCOLAC sont initialises a 0. A la fin ICOLAC est desactive.
  181.  
  182. IF (IIMPI.EQ.5) WRITE (IOIMP,801) NITLAC
  183. 801 FORMAT(' NOMBRE DE PILES CREEES : ',I5)
  184. C
  185. C on met la configuration courante dans la pile si pas deja
  186. C
  187. SEGACT ICOLAC
  188. ILISSE=ILISSP
  189. SEGACT ILISSE*MOD
  190. ILISSE=ILISSG
  191. SEGACT ILISSE*MOD
  192. ITLACC=KCOLA(33)
  193. SEGACT ITLACC*MOD
  194. ICFCO= MCOORD
  195. CALL AJOUN(ITLACC,ICFCO,ILISSE,iun)
  196. C --- REMPLISSAGE DES PILES A PARTIR DES DEMANDES
  197.  
  198. IF (LOBJ.EQ.0) THEN
  199. C ------ PAS D OBJETS NOMMES : ON SAUVE TOUT
  200. CALL LISTYP (MLCHA8)
  201. CALL FILLPO (ICOLAC,MLCHA8)
  202. SEGSUP MLCHA8
  203. ELSE
  204. CALL FILLLU(ISORTA,ICOLAC)
  205. ENDIF
  206. SEGSUP ISORTA
  207. CMB-- Maintenant ICOLAC contient la liste des objets a sauvegarder
  208.  
  209. C---- PETITE MAGOUILLE POUR LES OBJETS RIGIDITES
  210. C ET LES SUPER ELEMENTS
  211. CALL SORTRI(ICOLAC)
  212. C --- IER PASSAGE POUR COMPLETER LES PILES SANS CHANGER LES POINTEURS
  213. CALL FILLPI (ICOLAC)
  214.  
  215. IF (IIMPI.EQ.5)WRITE (IOIMP,802)
  216. 802 FORMAT(' PREMIER REMPLISSAGE DES PILES EFFECTUE')
  217.  
  218. C --- ON CHERCHE A COMPLETER LES CHAPEAUX DE CERTAINS OBJETS
  219. CALL HATRIG (ICOLAC)
  220. CALL HATSTR (ICOLAC)
  221. *
  222. * IL FAUT REAPPELLER SORTRI POUR LA PETITE MAGOUILLE
  223. * POUR LES EVENTUELLES RIGIDITES AJOUTEES PAR HATRIG
  224. C----PETITE MAGOUILLE POUR LES OBJETS RIGIDITES
  225. C ET LES SUPER ELEMENTS
  226. CALL SORTRI(ICOLAC)
  227. *
  228. C --- MISE A JOUR DU KCOLAC
  229. C CALL MAJICO (ICOLAC)
  230. C --- RECHERCHE DU NUMERO MAX DE POINT A PARTIR DE L ETAT
  231. C DES PILES 1 ET 32
  232. CALL MAXP1 (ICOLAC,IMAX)
  233. CALL MAXP32 (ICOLAC,I32MAX)
  234. IMAX= MAX(IMAX,I32MAX)
  235. C --- ON COMPLETE EVENTUELLEMENT LA PILE 1 A PARTIR DE TOUS LES OBJETS
  236. C MAILLAGE DONT LES NOEUDS SONT INFERIEURS A IMAX
  237. IIICHA=0
  238. CALL FILLP1 (ICOLAC,IMAX)
  239. C --- 2IEME PASSAGE SANS CHANGER LES POINTEURS
  240. C BECAUSE DES MELEME NOUVEAUX
  241. CALL FILLPI (ICOLAC)
  242.  
  243. IF (IIMPI.EQ.5)WRITE (IOIMP,803)
  244. 803 FORMAT(' SECOND REMPLISSAGE DES PILES EFFECTUE')
  245.  
  246. C --- MISE A JOUR DU KCOLAC
  247. C CALL MAJICO (ICOLAC)
  248. IF(IERR.NE.0) GOTO 5000
  249. C -------------------------------------------------------
  250. C --- RECHERCHE DES NOMS
  251. CALL FILLNO (ICOLAC)
  252.  
  253. C --- IMPRESSIONS INTERMEDIAIRES DES PILES
  254. IVOULU=0
  255. IF(IIMPI.EQ.6) CALL IMPPIL (ICOLAC,IVOULU)
  256.  
  257. C --- 3IEME PASSAGE CHANGEMENT DES POINTEURS
  258. CALL SAVEPI (ICOLAC)
  259. IF (IIMPI.EQ.5)WRITE (IOIMP,804)
  260. 804 FORMAT(' CHANGEMENT DES POINTEURS EFFECTUE ')
  261. C
  262. C--------------------------------------------------------
  263. C **** ECRITURE SUR LE FICHIER DE SORTIE
  264. C --- ECRITURE DES PILES
  265. C REWIND IOSAU
  266. CALL WRPIL (ICOLAC,IMAX,IFORM,LABEL,ISILEN)
  267.  
  268. IF (IIMPI.EQ.5) WRITE (IOIMP,805)
  269. 805 FORMAT(' SAUVETAGE EFFECTUE ')
  270.  
  271. C --- RESTAURATION DES POINTEURS
  272. CALL RESTPI (ICOLAC)
  273.  
  274. IF (IIMPI.EQ.5)WRITE (IOIMP,806)
  275. 806 FORMAT(' RESTAURATION DES POINTEURS EFFECTUEE ')
  276. C-------------------------------------------------------------
  277. C --- SUPPRESSION DES PILES (IVOULU=0)
  278. IVOULU=0
  279. CALL SUPPIL (ICOLAC,IVOULU)
  280. IF (IIMPI.EQ.5) WRITE (IOIMP,807)
  281. 807 FORMAT(' SUPPRESSION DES PILES EFFECTUEE ')
  282.  
  283. CALL ERREUR(-276)
  284. C MODI N.BLAY LE 17/09/91 POUR VIDER LES BUFFERS.-------------
  285. C REWIND IOSAU
  286. if (iform.eq.2) then
  287. if (ixdrw.ne.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
  288. ** write (6,*) ' sauv reouverture de ',nomfic
  289. ios= initxdr(NOMFIC(1:long(nomfic)),'a',.TRUE.)
  290. endif
  291. C * attention aux assistants ....
  292. if (NBESC.NE.0) then
  293. C * il faut liberer le segment de dialogue
  294. mestra=imestr
  295. * repasser en mode normal
  296. call ooofrc(0)
  297. SEGDES MESTRA
  298. * lodesl=.false.
  299. call setass(0)
  300. end if
  301. GO TO 11
  302. 5000 CONTINUE
  303. CALL ERREUR(558)
  304.  
  305. 11 RETURN
  306. END
  307.  
  308.  
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  

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