Télécharger chkesc.eso

Retour à la liste

Numérotation des lignes :

  1. C CHKESC SOURCE CB215821 19/08/20 21:15:44 10287
  2. SUBROUTINE CHKESC(IRT,IMENA)
  3.  
  4. C CHKESC REGARDE SI IL Y A DANS L'INSTRUCTION UN OBJET DE TYPE //
  5. C SI C'EST LE CAS, IL RAJOUTE ASSI TOUS DANS L'INSTRUCTION
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC CCNOYAU
  10. -INC SMTABLE
  11. -INC SMCHAML
  12. -INC SMMODEL
  13. -INC CCOPTIO
  14.  
  15. CHARACTER*8 TYPOBJ,CHA8,CHARRE,CHACRE
  16. LOGICAL LOGR1,LOGR2
  17.  
  18. PARAMETER (NBMO1=8)
  19. CHARACTER*4 LESMOT(NBMO1)
  20.  
  21. C LESMOT = LISTE DES OPÉRATEURS GÉRANT LES OBJEST ESCLAVES
  22. DATA LESMOT/'ASSI','LIST','DETR','ETG ',
  23. & 'TYPE','DEBP','FINP','RESP'/
  24.  
  25. PARAMETER (NBMO2=46)
  26. CHARACTER*4 LESMO2(NBMO2)
  27. C LESMO2 = LISTE DES OPÉRATEURS DEMANDANT UNE FUSION DES OBJETS
  28. C AVANT DE LES APPELER
  29. DATA LESMO2/'MASQ','TYPE','EXIS','FORM','NLOC','TRAC','PROI',
  30. & 'ELIM','POIN','NOEU','ARET','CERC','DROI','CONT',
  31. & 'DALL','ENVE','FACE','REGL','ROTA','SURF','TRAN',
  32. & 'PAVE','VOLU','PART','AFFI','CONF','DEPL','DIFF',
  33. & 'ELEM','HOMO','INCL','INTE','INVE','ORDO','PROJ',
  34. & 'RAFF','RAFT','REGE','SYME','TOUR','PLUS','MOIN',
  35. & 'UNIQ','DIME','EXTR','SI '/
  36.  
  37. PARAMETER (NBMO3=2)
  38. CHARACTER*4 LESMO3(NBMO3)
  39. C LESMO3 = LISTE DES OPERATEURS EXECUTES EN PARALLELE ALORS QU''UN
  40. C MCHAML (NON //) A ETE LU SANS MMODEL
  41. DATA LESMO3/'REDU','SOUC'/
  42.  
  43. C BREDUC : BOOLEEN PERMETTANT D'ENCLENCHER LA FUSION
  44. C BREMPL : BOOLEEN PERMETTANT DE REMPLACER DANS LA PILE LA TABLE PAR L'OBJET FUSIONNE
  45. LOGICAL BREDUC,BREMPL,BREDU2,BREMP2,BSPECI
  46. LOGICAL BMAX
  47.  
  48. C SID : SEGMENT CONTENANT LES INFORMATIONS POUR LA FUSION DES OBJETS
  49. SEGMENT SID
  50. C NBFUS : NOMBRE D'OBJETS A FUSIONNER
  51. C IPOINT : POINTEURS SUR LES NBESC OBJETS A FUSIONNER
  52. C BVAL : LOGIQUES SUR LESQUELS ON FAIT UN ET LOGIQUE
  53. C XVAL : VALEURS MAXI / MINI LOCALES A FUSIONNER
  54. C CHATYP : MOT DONNANT LE TYPE D'OBJETS A FUSIONNER
  55. INTEGER IPOINT(NBFUS)
  56. LOGICAL BVAL (NBFUS)
  57. REAL*8 XVAL (NBFUS)
  58. CHARACTER*8 CHATYP
  59. ENDSEGMENT
  60.  
  61. C
  62. C POUR TOUT AUTRE OPÉRATEUR EN PRÉSENCE DE TABLE ESCLAVE
  63. C (SAUF DE TYPE CHPOINT OU RIGIDITE)
  64. C ON INSERE "ASSIS TOUS" AU DÉBUT DE LA PHRASE GIBIANE
  65. C SANS FAIRE DE FUSION.
  66. C LES TABLES ESCLAVE DE CHPOINT, DE RIGIDITE, DE FLOTTANT ET DE LOGIQUE
  67. C SONT TOUJOURS ASSEMBLÉES
  68. C EN SORTIE : IRT =1 VEUT DIRE ALLER DANS ASSISTANT
  69. C : IMENA=0 VEUT DIRE NE PAS FAIRE DE MENAGE TOUT DE SUITE
  70. C CAR FUSION SANS REMPLACEMENT DANS TABLE DES OBJETS
  71.  
  72. DIMENSION IAZ(100)
  73.  
  74.  
  75. C WRITE(6,*) ' ENTREE DANS CHKESC'
  76. BREDUC = .FALSE.
  77. BREDU2 = .FALSE.
  78. BREMPL = .FALSE.
  79. BSPECI = .FALSE.
  80. BMAX = .TRUE.
  81. IRT = 0
  82. ILUOB = 0
  83. IMENA = 1
  84.  
  85. IREPRO = 0
  86. IREMOD = 0
  87. IRECHA = 0
  88. IREESC = 0
  89. IMOT1 = 0
  90. IMOT2 = 0
  91. IMOT3 = 0
  92. IRETOU = 0
  93. IRET = 0
  94.  
  95. CALL LIROBJ('PROCEDUR',IRET,0,IREPRO)
  96. IF (IREPRO.NE.0) THEN
  97. CALL REFUS
  98. C WRITE (6,*) ' CHKESC : Lecture d''une PROCEDUR'
  99. RETURN
  100. ENDIF
  101.  
  102. C IBLQM =0 PERMET À GIBIANE DE LIRE AU DELÀ DES MOTS
  103. IBLQM=0
  104.  
  105. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  106. C Lecture de MOTS et d''OBJETS intervenants dans la LOGIQUE de CHKESC
  107. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  108. CALL LIRMOT(LESMOT,NBMO1,IMOT1,0)
  109. IF (IMOT1.NE.0) THEN
  110. CALL REFUS
  111. C WRITE (6,*) ' CHKESC ',LESMOT(IMOT1)
  112. RETURN
  113. ENDIF
  114.  
  115. CALL LIRMOT(LESMO2,NBMO2,IMOT2,0)
  116. IF (IMOT2.NE.0) THEN
  117. C IF (IMOT2 .EQ. 7) THEN
  118. CC Cas un peu particulier de l''operateur 'PROI'
  119. C BSPECI = .TRUE.
  120. C ENDIF
  121. CALL REFUS
  122. ELSE
  123. CALL LIRMOT(LESMO3,NBMO3,IMOT3,0)
  124. IF (IMOT3.NE.0) THEN
  125. CALL REFUS
  126. ENDIF
  127. ENDIF
  128.  
  129. CALL LIROBJ('MMODEL',IRET,0,IREMOD)
  130. IF (IREMOD.NE.0) THEN
  131. MMODEL=IRET
  132. CALL REFUS
  133. ENDIF
  134.  
  135. CALL LIROBJ('MCHAML',IRET,0,IRECHA)
  136. IF (IRECHA.NE.0) THEN
  137. MCHELM=IRET
  138. CALL REFUS
  139. ENDIF
  140.  
  141. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  142. C Logique generale de Fusion & Remplacement des OBJETS
  143. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  144. IF (IMOT2.NE.0) THEN
  145. C Fusion pour les Operateurs de LESMO2
  146. BREDUC=.TRUE.
  147. BREMPL=.FALSE.
  148.  
  149. ELSEIF(IMOT3 .NE. 0) THEN
  150. IF (IREMOD .NE. 0) THEN
  151. C Un MMODEL dans 'REDU' enclenche la fusion sans remplacement
  152. BREDUC=.TRUE.
  153. BREMPL=.FALSE.
  154. ENDIF
  155.  
  156. ELSEIF ((IRECHA .NE. 0) .OR. (IREMOD .NE. 0)) THEN
  157. C Un MMODEL ou un MCHAML enclenche la fusion avec remplacement
  158. BREDUC=.TRUE.
  159. BREMPL=.TRUE.
  160. ENDIF
  161.  
  162.  
  163. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  164. C Boucle sur les arguments de la ligne decodee
  165. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  166. IASSS=0
  167.  
  168. C Cas de souci
  169. IF (IMOT3.EQ.2) then
  170. IASSS=1
  171. ENDIF
  172. DO 10 ICCC=1,100
  173. IBLQM=0
  174. CALL LIRTAB('ESCLAVE',MTABLE,0,IREESC)
  175. ILUOB=ILUOB+1
  176. IAZ(ILUOB)=IMOTLU
  177. IBLQM=1
  178. IF (IREESC.EQ.0) THEN
  179. IF(IASSS.EQ.1)THEN
  180. GOTO 100
  181. ELSE
  182. C WRITE(6,*)'CHKESC : Sortie n_3'
  183. RETURN
  184. ENDIF
  185. ENDIF
  186.  
  187. TYPOBJ=' '
  188.  
  189. C RECHERCHE DU CREATEUR (MTABLE ressort SEGACT dans les ASSISTANT)
  190. CALL ACCTAB(MTABLE,'MOT ',IND ,0.D0 ,'CREATEUR',.TRUE.,0 ,
  191. & 'MOT ',IVALRE,XVALRE,CHACRE ,LOGR1 ,ID1)
  192. IF (IERR.NE.0) RETURN
  193.  
  194. ML=MLOTAB
  195. C DIMENSIONNEMENT DU SEGMENT SID A (ML - 2) a cause des indices 'SOUSTYPE' et 'CREATEUR'
  196. NBFUS = ML - 2
  197. SEGINI,SID
  198. NBENT = 0
  199.  
  200. IND=1
  201. CALL ACCTAB(MTABLE,'ENTIER',IND ,0.D0 ,' ',.TRUE.,0,
  202. & TYPOBJ ,IVALRE,XVALRE,CHARRE,LOGR1 ,ID1)
  203. IF (IERR.NE.0) RETURN
  204.  
  205. IF ((IRECHA .NE. 0) .AND. (TYPOBJ .EQ. 'MCHAML')) THEN
  206. C PLANTE SUR LES COMMANDES AVEC MCHAML // ET NORMAUX
  207. C WRITE(*,*)'Utilisation de MCHAML // et MCHAML normaux'
  208. C CALL TRBAC
  209. C CALL ERREUR(21)
  210. C WRITE(6,*)'CHKESC : Sortie n_4'
  211. C RETURN
  212. ENDIF
  213.  
  214. IF ((IRECHA .NE. 0) .AND. (TYPOBJ .EQ. 'MMODEL') .AND.
  215. & (IMOT3 .EQ. 0)) THEN
  216. C PLANTE SUR LES COMMANDES AVEC MMODEL // ET MCHAML NORMAUX
  217. C WRITE(*,*)'Utilisation de MMODEL // et MCHAML normaux'
  218. C CALL TRBAC
  219. C CALL ERREUR(21)
  220. C WRITE(6,*)'CHKESC : Sortie n_5'
  221. C RETURN
  222. ENDIF
  223.  
  224. IF (IMOT2 .EQ. 0) THEN
  225. IF (TYPOBJ .EQ. 'MMODEL') THEN
  226. C PAS DE REDUCTION SI UN MMODEL ESCLAVE EST RENCONTRE
  227. BREDUC = .FALSE.
  228. IASSS=1
  229. GOTO 10
  230.  
  231. ELSEIF((TYPOBJ.EQ.'MCHAML '.OR. TYPOBJ .EQ. 'MAILLAGE' .OR.
  232. & TYPOBJ.EQ.'ENTIER ') .AND. (.NOT. BREDUC)) THEN
  233. IASSS=1
  234. GOTO 10
  235. ENDIF
  236. ELSEIF(BSPECI) THEN
  237. IASSS=1
  238. GOTO 10
  239. ENDIF
  240.  
  241. C Regles locales de remplacement
  242. BREDU2 = BREDUC
  243. BREMP2 = BREMPL
  244. IF (CHACRE .EQ. 'SOUC') THEN
  245. BMAX = .FALSE.
  246. ENDIF
  247. IF (TYPOBJ .EQ. 'FLOTTANT') THEN
  248. BREDU2 = .TRUE.
  249. BREMP2 = .TRUE.
  250.  
  251. IF (CHACRE .EQ. 'MAXI') THEN
  252. BMAX = .TRUE.
  253. ELSEIF (CHACRE .EQ. 'MINI') THEN
  254. BMAX = .FALSE.
  255. ELSE
  256. CALL ERREUR(21)
  257. RETURN
  258. ENDIF
  259.  
  260. ELSEIF ((TYPOBJ.EQ.'RIGIDITE') .OR. (TYPOBJ.EQ.'CHPOINT ').OR.
  261. & (TYPOBJ.EQ.'LOGIQUE ' )) THEN
  262. BREDU2 = .TRUE.
  263. BREMP2 = .TRUE.
  264. ENDIF
  265.  
  266. IF (BREDU2) THEN
  267. IF (TYPOBJ .NE. 'RIGIDITE' .AND. TYPOBJ .NE. 'CHPOINT ' .AND.
  268. & TYPOBJ .NE. 'LOGIQUE ' .AND. TYPOBJ .NE. 'FLOTTANT' .AND.
  269. & IMOT2 .EQ. 0 .AND. IMOT3.EQ. 0) THEN
  270. C WRITE(*,*)TYPOBJ,BREMP2,BREMPL
  271. C WRITE(*,*)'FUSION CHKESC ANORMALE...'
  272. C CALL ERREUR(21)
  273. C RETURN
  274. ENDIF
  275.  
  276. C REMPLISSAGE DU SEGMENT SID POUR LA FUSION
  277. NBENT = NBENT + 1
  278. SID.IPOINT(NBENT)= ID1
  279. SID.BVAL (NBENT)= LOGR1
  280. SID.XVAL (NBENT)= XVALRE
  281. SID.CHATYP = TYPOBJ
  282. CHA8 = TYPOBJ
  283.  
  284. IF (ML .GE. 4) THEN
  285. DO I=4,ML
  286. C La TABLE n'est plus SEGDES par acctab pour les ESCLAVES
  287. IND=i-2
  288. CALL ACCTAB(MTABLE,'ENTIER',IND ,0.D0 ,' ',.TRUE.,0,
  289. & TYPOBJ ,IVALRE,XVALRE,CHARRE,LOGR2 ,ID2)
  290. IF (IERR.NE.0) RETURN
  291.  
  292. IF (TYPOBJ .NE. CHA8) THEN
  293. C ERREUR SI LES TYPES SONT DIFFERENTS ENTRE 2 INDICES DE LA TABLE ESCLAVE
  294. MOTERR(1:8 ) = CHA8
  295. MOTERR(9:16) = TYPOBJ
  296. CALL ERREUR(1045)
  297. SEGSUP,SID
  298. WRITE(6,*)'CHKESC : Sortie n_7'
  299. RETURN
  300. ENDIF
  301.  
  302. C REMPLISSAGE DU SEGMENT SID POUR LA FUSION PAR TOURNOI
  303. NBENT=NBENT + 1
  304. SID.IPOINT(NBENT)= ID2
  305. SID.BVAL(NBENT) = LOGR2
  306. SID.XVAL(NBENT) = XVALRE
  307. ENDDO
  308. ENDIF
  309.  
  310. C LANCEMENT DE LA FUSION DES OBJETS
  311. C IF (IIMPI .EQ. 215821) THEN
  312. C WRITE(IOIMP,*)'FUSION ENCLENCHEE DANS CHKESC : ',CHA8,BREMP2
  313. C CALL TRBAC
  314. C ENDIF
  315. ID = SID
  316. CALL FUNOBJ(ID,ID1,XVALRE,LOGR1,BMAX)
  317. CALL ACTOBJ(TYPOBJ,ID1,1)
  318.  
  319. IF (TYPOBJ.EQ.'LOGIQUE' ) THEN
  320. CALL POSLOG(LOGR1,ID1)
  321.  
  322. ELSEIF (TYPOBJ.EQ.'FLOTTANT') THEN
  323. CALL POSREE(XVALRE,ID1)
  324. ENDIF
  325.  
  326. IF(TYPOBJ.EQ.'MATRIK ' .OR. TYPOBJ.EQ.'MCHAML ' .OR.
  327. & TYPOBJ.EQ.'MMODEL ' .OR. TYPOBJ.EQ.'MAILLAGE' ) THEN
  328. IMENA=0
  329. ENDIF
  330.  
  331. C REMPLACEMENT DE LA TABLE PAR LE RESULTAT DE LA FUSION
  332. C - Dans la pile GIBIANE
  333. C - Dans la pile des NOMS si BREMP2 est VRAI
  334. CALL RMPGBN(MTABLE,ID1,TYPOBJ,BREMP2)
  335.  
  336. ELSE
  337. WRITE(IOIMP,*)'ERREUR DANS CHKESC.ESO,',TYPOBJ
  338. CALL ERREUR(21)
  339. RETURN
  340. ENDIF
  341.  
  342. SEGSUP,SID
  343. 10 CONTINUE
  344.  
  345. C
  346. 100 CONTINUE
  347. C CALL REFUS
  348. DO IAZI=1,ILUOB
  349. IMOTLU=IAZ(IAZI)
  350. IF(IMOTLU.NE.0) THEN
  351. JPOOB1(IMOTLU)=.TRUE.
  352. IF(IBPILE.GT.IMOTLU) IBPILE=IMOTLU
  353. IF(IHPILE.LT.IMOTLU) IHPILE=IMOTLU
  354. ENDIF
  355. ENDDO
  356. CHARRE=' '
  357. CALL LIRCHA(CHARRE,0,IRETOU)
  358. IF (IRETOU.NE.0) CALL REFUS
  359. IF (IRETOU.EQ.0) RETURN
  360. C CALL TRBAC
  361. IRT=1
  362.  
  363. C WRITE(6,*)'CHKESC : Sortie n_8 NORMALE'
  364. END
  365.  
  366.  
  367.  

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