Télécharger etg.eso

Retour à la liste

Numérotation des lignes :

etg
  1. C ETG SOURCE CB215821 25/05/16 21:15:01 12269
  2. SUBROUTINE ETG
  3.  
  4. implicit integer (i-n)
  5. implicit real*8(a-h,o-z)
  6.  
  7. external long
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC SMTABLE
  12. -INC SMLOBJE
  13. -INC CCNOYAU
  14. -INC CCASSIS
  15. -INC CCPRECO
  16.  
  17. LOGICAL LOGR1,LOGR2
  18. REAL*8 XVALRE,XVALR2
  19. CHARACTER*(8) TYOBJE,CHA8,CHACRE
  20. CHARACTER*(LOCHAI) CHARRE
  21.  
  22. C Objets geres par les TABLES 'ESCLAVE'
  23. PARAMETER(NBOK=16)
  24. CHARACTER*(8) OBJOK(NBOK)
  25. DATA OBJOK /'CHPOINT ','RIGIDITE','LOGIQUE ','MCHAML ','MMODEL',
  26. $ 'MAILLAGE','MATRIK ','FLOTTANT','EVOLUTIO','ENTIER',
  27. $ 'MOT' ,'CHARGEME','LISTREEL','LISTENTI','LISTMOTS',
  28. $ 'POINT '/
  29.  
  30. C MACRO a synchroniser avec le DATA OBJOK pour test rapide d'entiers
  31. MACRO,(CHPOINT ,RIGIDITE,LOGIQUE ,MCHAML ,MMODEL,
  32. > MAILLAGE,MATRIK ,FLOTTANT,EVOLUTIO,ENTIER,
  33. > MOT,CHARGEME,LISTREEL,LISTENTI,LISTMOTS,POINT)
  34.  
  35. C Objets geres par les LISTOBJ
  36. PARAMETER(NBOK2=13)
  37. CHARACTER*(8) OBJOK2(NBOK2)
  38. DATA OBJOK2/'CHPOINT ','RIGIDITE','MCHAML ','MMODEL','MAILLAGE',
  39. $ 'MATRIK ','EVOLUTIO','ENTIER ','CHARGEME','LISTREEL'
  40. $ ,'LISTENTI','LISTMOTS','POINT' /
  41.  
  42. C SID : SEGMENT CONTENANT LES INFORMATIONS POUR LA FUSION DES OBJETS
  43. SEGMENT SID
  44. C NBFUS : NOMBRE D'OBJETS A FUSIONNER
  45. C IPOINT : POINTEURS A FUSIONNER ou ENTIERS A FUSIONNER (cas particuler MAXI / MINI)
  46. C BVAL : LOGIQUES SUR LESQUELS ON FAIT UN ET/OU LOGIQUE
  47. C XVAL : REELS A FUSIONNER (cas particuler MAXI / MINI)
  48. C CVAL : MOTS A FUSIONNER (cas particuler MAXI / MINI)
  49. C CHATYP : MOT DONNANT LE TYPE D'OBJETS A FUSIONNER
  50. INTEGER IPOINT(NBFUS)
  51. LOGICAL BVAL (NBFUS)
  52. REAL*8 XVAL (NBFUS)
  53. CHARACTER*(IC1) CVAL (NBFUS)
  54. CHARACTER*8 CHATYP,CREATE
  55. ENDSEGMENT
  56.  
  57. LOGR1 = .FALSE.
  58. LOGR2 = .FALSE.
  59. XVALRE= 0.D0
  60. XVALR2= 0.D0
  61.  
  62.  
  63. CC Lecture du premier objet
  64. CC ------------------------
  65. CALL MESLIR(-225)
  66. CALL QUETYP(TYOBJE,0,IRETOU)
  67. IF(IRETOU.EQ.0) THEN
  68. CC Cet opérateur a encore besoin d'un opérande.
  69. CALL ERREUR (533)
  70. RETURN
  71. ENDIF
  72. CALL LIROBJ(TYOBJE,IP1,1,IRETOU)
  73.  
  74. IF(TYOBJE.EQ.'TABLE ') THEN
  75. MTABLE = IP1
  76. CALL ACCTAB(MTABLE,'MOT',0,0.D0 ,'SOUSTYPE',.TRUE.,0,
  77. > 'MOT',IENT1,XVALRE, TYOBJE ,LOGR1 ,ID1)
  78. IF (TYOBJE.NE.'ESCLAVE') THEN
  79. CC Donnez une TABLE de sous-type %m1:8
  80. MOTERR ='ESCLAVE'
  81. CALL ERREUR(-173)
  82. CC Le sous-type de la table est incorrect
  83. CALL ERREUR(648)
  84. RETURN
  85. ENDIF
  86.  
  87. SEGACT,MTABLE
  88. ML=MLOTAB
  89.  
  90. C RECHERCHE DU CREATEUR
  91. CALL ACCTAB(MTABLE,'MOT ',IND ,0.D0 ,'CREATEUR',.TRUE.,0
  92. $ ,'MOT ',IENT1,XVALR2,CHACRE ,LOGR2 ,ID2)
  93. IF (IERR.NE.0) RETURN
  94. NBENT = 0
  95. IND = 1
  96. TYOBJE=' '
  97. CALL ACCTAB(MTABLE,'ENTIER',IND ,0.D0 ,' ',.TRUE.,0 ,
  98. & TYOBJE ,IENT1,XVALRE ,CHARRE,LOGR1 ,ID1 )
  99. IF (IERR.NE.0) RETURN
  100.  
  101. C Verification que ETG traite bien ce type d'objet
  102. CALL PLAMO8(OBJOK,NBOK,IPLAC,TYOBJE)
  103.  
  104. C DIMENSIONNEMENT DU SEGMENT SID A (ML - 2) a cause des indices 'SOUSTYPE' et 'CREATEUR'
  105. NBFUS = ML - 2
  106. IF(IPLAC .EQ. MOT)THEN
  107. IC1 = LONG(CHARRE)
  108. ELSE
  109. IC1 = 0
  110. ENDIF
  111. SEGINI,SID
  112. SID.CREATE=CHACRE
  113.  
  114. IF(IPLAC .EQ. MMODEL)THEN
  115. C Verification si le MMODEL partitionne est deja dans le CCPRECO (resultat instantanné)
  116. DO IIMOD = 1, NMOPAR
  117. IF (PESCLA(IIMOD) .EQ. 0) THEN
  118. C On sort
  119. GOTO 1
  120. ELSEIF (MTABLE .EQ. PESCLA(IIMOD)) THEN
  121. imodel = PARMOD(IIMOD)
  122. CALL ACTOBJ('MMODEL',imodel,1)
  123. CALL ECROBJ('MMODEL',imodel)
  124. SEGSUP,SID
  125. SEGDES,MTABLE
  126. RETURN
  127. ENDIF
  128. ENDDO
  129. ENDIF
  130. 1 CONTINUE
  131.  
  132. IF (IPLAC .GT. 0) THEN
  133. C REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
  134. NBENT = NBENT + 1
  135. IF(IPLAC .EQ. ENTIER)THEN
  136. SID.IPOINT(NBENT)= IENT1
  137. ELSE
  138. SID.IPOINT(NBENT)= ID1
  139. ENDIF
  140. SID.BVAL (NBENT)= LOGR1
  141. SID.XVAL (NBENT)= XVALRE
  142. IF(IPLAC .EQ. MOT)THEN
  143. SID.CVAL(NBENT)= CHARRE
  144. ENDIF
  145. SID.CHATYP = TYOBJE
  146. CHA8 = TYOBJE
  147.  
  148. IF (NBFUS .GE. 2) THEN
  149. DO I=2,NBFUS
  150. IND = I
  151. CALL ACCTAB(MTABLE,'ENTIER ',IND,0.D0,' ',.TRUE.,0,
  152. & TYOBJE,IENT2,XVALRE,CHARRE,LOGR2,ID2)
  153. IF (IERR.NE.0) RETURN
  154. IF (TYOBJE .NE. CHA8) THEN
  155. C ERREUR SI LES TYPES SONT DIFFERENTS ENTRE 2 INDICES DE LA TABLE ESCLAVE
  156. MOTERR = CHA8
  157. MOTERR(9:16) = TYOBJE
  158. CALL ERREUR(1045)
  159. SEGSUP,SID
  160. RETURN
  161. ENDIF
  162.  
  163. C REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
  164. NBENT=NBENT + 1
  165. IF(IPLAC .EQ. ENTIER)THEN
  166. SID.IPOINT(NBENT)= IENT2
  167. ELSE
  168. SID.IPOINT(NBENT)= ID2
  169. ENDIF
  170. SID.BVAL (NBENT)= LOGR2
  171. SID.XVAL (NBENT)= XVALRE
  172. IF(IPLAC .EQ. MOT)THEN
  173. IF(LONG(CHARRE) .GT. IC1)THEN
  174. IC1 = LONG(CHARRE)
  175. SEGADJ,SID
  176. ENDIF
  177. SID.CVAL(NBENT)= CHARRE
  178. ENDIF
  179. ENDDO
  180. ENDIF
  181.  
  182. C LANCEMENT DE LA FUSION DES OBJETS
  183. C WRITE(IOIMP,*)'FUSION ENCLENCHEE DANS ETG : ',CHA8
  184. ID = SID
  185. CALL FUNOBJ(ID,ID1,XVALRE,LOGR1)
  186. IF(IERR .NE. 0) RETURN
  187.  
  188. ELSE
  189. C Type d'objet non traite par ETG
  190. MOTERR = TYOBJE
  191. CALL ERREUR(1046)
  192. RETURN
  193. ENDIF
  194.  
  195. ELSEIF(TYOBJE.EQ.'LISTOBJE') THEN
  196. MLOBJE = IP1
  197. SEGACT,MLOBJE
  198. ML = MLOBJE.LISOBJ(/1)
  199. CHACRE =' '
  200. TYOBJE = MLOBJE.TYPOBJ
  201.  
  202. C Verification que ETG traite bien ce type d'objet
  203. CALL PLAMO8(OBJOK2,NBOK2,IPLAC2,TYOBJE)
  204.  
  205. C On trouve IPLAC dans OBJOK pour le "CASE, IPLAC"
  206. CALL PLAMO8(OBJOK ,NBOK ,IPLAC ,TYOBJE)
  207.  
  208. IF(IPLAC .EQ. MOT)THEN
  209. IC1 = LONG(CHARRE)
  210. ELSE
  211. IC1 = 0
  212. ENDIF
  213. NBFUS = ML
  214. SEGINI,SID
  215. SID.CREATE= CHACRE
  216. SID.CHATYP= TYOBJE
  217. IF (IPLAC2 .GT. 0) THEN
  218. C REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
  219. DO I=1,ML
  220. SID.IPOINT(I)=LISOBJ(I)
  221. ENDDO
  222. C LANCEMENT DE LA FUSION DES OBJETS
  223. C WRITE(IOIMP,*)'FUSION ENCLENCHEE DANS ETG : ',TYOBJE
  224. ID = SID
  225. CALL FUNOBJ(ID,ID1,XVALRE,LOGR1)
  226. IF(IERR .NE. 0) RETURN
  227.  
  228. ELSE
  229. MOTERR = TYOBJE
  230. CALL ERREUR(1046)
  231. RETURN
  232. ENDIF
  233.  
  234. ELSE
  235. CALL REFUS
  236. RETURN
  237. ENDIF
  238.  
  239. C Ecriture du resultat dans la pile
  240. C write(ioimp,*) 'iplac,tyobje=',iplac,tyobje
  241. CASE, IPLAC
  242. WHEN, LOGIQUE
  243. CALL ECRLOG(LOGR1)
  244. WHEN, MOT
  245. CALL ACTOBJ('LISTMOTS',ID1,1)
  246. CALL ECROBJ('LISTMOTS',ID1)
  247. WHEN, ENTIER
  248. C Il manque la gestion de MAXI et MINI pour ce cas la !
  249. CALL ACTOBJ('LISTENTI',ID1,1)
  250. CALL ECROBJ('LISTENTI',ID1)
  251. WHEN, FLOTTANT
  252. IF(ID1 .EQ. 0)THEN
  253. CALL ECRREE(XVALRE)
  254. ELSE
  255. CALL ACTOBJ('LISTREEL',ID1,1)
  256. CALL ECROBJ('LISTREEL',ID1)
  257. ENDIF
  258. WHEN, POINT
  259. CALL ACTOBJ('MAILLAGE',ID1,1)
  260. CALL ECROBJ('MAILLAGE',ID1)
  261. WHENOTHERS
  262. C Cas des POINTEURS sur des OBJETS
  263. CALL ACTOBJ(TYOBJE,ID1,1)
  264. CALL ECROBJ(TYOBJE,ID1)
  265. ENDCASE
  266.  
  267. SEGSUP,SID
  268. IF(TYOBJE.EQ.'TABLE ') THEN
  269. SEGDES,MTABLE
  270. ELSEIF(TYOBJE.EQ.'LISTOBJE') THEN
  271. SEGACT,MLOBJE
  272. ENDIF
  273.  
  274. RETURN
  275. END
  276.  
  277.  
  278.  

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