Télécharger etg.eso

Retour à la liste

Numérotation des lignes :

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

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