Télécharger chkesc.eso

Retour à la liste

Numérotation des lignes :

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

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