Télécharger sauv.eso

Retour à la liste

Numérotation des lignes :

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

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