Télécharger etg.eso

Retour à la liste

Numérotation des lignes :

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

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