Télécharger assist.eso

Retour à la liste

Numérotation des lignes :

  1. C ASSIST SOURCE CB215821 19/01/29 21:15:01 10088
  2. C operateur assistant
  3. C
  4. SUBROUTINE ASSIST(irtous)
  5. IMPLICIT INTEGER(I-N)
  6. -INC CCOPTIO
  7. -INC CCNOYAU
  8. -INC SMTABLE
  9. -INC SMLMOTS
  10. -INC CCASSIS
  11. -INC SMCOORD
  12. -INC SMBLOC
  13. character*8 ityp,mparam,typobj
  14. logical ilog,BMAXI,BMINI,bsouc
  15. real*8 reel
  16. character*72 chaine
  17. logical LOGIN,LOGRE
  18. character*72 CHARIN,CHARRE
  19. real*8 XVALIN,XVALRE
  20. C
  21. C logique pour l option TOUS
  22. logical LOTOUS
  23. C integer pour existence de table esclave (pointe sur table esclave)
  24. integer ITABESC
  25. C table de stockage du numero des assistants
  26. C SP 2016 : on cree un segment pour ne plus avoir de limitation
  27. C sur le nombnre d'assistants par la taille du tableau
  28. SEGMENT TABASSI
  29. integer ITABASS(NASS)
  30. ENDSEGMENT
  31. C nombre total d operations a distribue
  32. integer inbass
  33. C table de stockage des tables resultats
  34. integer itabres(20)
  35. BMAXI = .FALSE.
  36. BMINI = .FALSE.
  37. Bsouc = .FALSE.
  38. ITABESC = 0
  39. inbass = 0
  40. C* test si assistants deja demarres. Sion on les demarre
  41. if (nbesc.eq.0.and.nbescr.ne.0) then
  42. call iniass(nbescr)
  43. nbesc=nbescr
  44. endif
  45. C
  46. C lecture du n° de process ou de l option tous
  47. C
  48. C l'opti assi a-t-il été défini ? non ? pas un probleme - PV
  49. C if (.not. LODEFE) then
  50. C JYY print*,'pas d''assistants déclarés !!!!'
  51. C CALL ERREUR (893)
  52. C return
  53. C end if
  54.  
  55. call quetyp(ityp,0,iretou)
  56. if (iretou.eq.0) then
  57. C JYY print*,'erreur de syntaxe dans l operateur'
  58. CALL ERREUR ( 880 )
  59. return
  60. end if
  61. if(irtous.eq.0) then
  62. if (ityp .EQ. 'MOT ') then
  63. call lircha(mparam,1,iretou)
  64. if (mparam.EQ.'TOUS ') then
  65. LOTOUS = .TRUE.
  66. else
  67. C JYY print*,'erreur de syntaxe dans l operateur'
  68. CALL ERREUR ( 880 )
  69. return
  70. end if
  71. else
  72. LOTOUS = .FALSE.
  73. call lirent(iproc0,1,iretou)
  74. if (iproc0.eq.0) iproc0=1
  75. end if
  76. else
  77. LOTOUS=.TRUE.
  78. endif
  79. C pv si on n'a pas d'assistants, on rend la main
  80. if (nbesc.eq.0) return
  81. C
  82. C Prevenir les instructions qu l'on est dans l'assistant
  83. C LODESL = .TRUE.
  84. call setass(1)
  85. C pour la trace des erreurs
  86. CALL ANABAC
  87. C Lecture de la pile
  88. C ------------------
  89. segini mescla
  90. mescl1 = mescla
  91. jjjerr = 0
  92.  
  93. C mettre les operandes
  94. C On va utiliser esoplu pour determiner la position des tables ESCLAVE
  95. do 5 iop=1,100
  96. esoplu(iop)=.true.
  97. 5 continue
  98. do 10 iop=1,90
  99. call quetyp(ityp,0,iretou)
  100. if (iretou.eq.0) goto 11
  101. esoplu(iop+10)=.false.
  102. esopty(iop+10)=ityp
  103. if (ityp.eq.'LOGIQUE ') then
  104. call lirlog(ilog,1,iretou)
  105. esoplo(iop+10)=ilog
  106. elseif(ityp.eq.'FLOTTANT') then
  107. call lirree(reel,1,iretou)
  108. esopre(iop+10)=reel
  109. elseif (ityp.eq.'MOT ') then
  110. call lircha(chaine,1,iretou)
  111. esopch(iop+10)=chaine
  112. esopva(iop+10)=iretou
  113. if (chaine.eq.'MAXI ') then
  114. bmaxi=.TRUE.
  115. elseif (chaine.eq.'MINI ') then
  116. bmini=.TRUE.
  117. elseif (chaine(1:4).eq.'SOUC') then
  118. bsouc=.TRUE.
  119. endif
  120. else
  121. C cas des objets
  122. call lirobj(ityp,iob,1,iretou)
  123. esopva(iop+10)=iob
  124. IF (ityp .EQ. 'TABLE ') then
  125. C recherche du sous type
  126. typobj = ' '
  127. call acctab(iob,'MOT ',IVALIN,XVALIN,'SOUSTYPE',LOGIN,
  128. & IOBIN,typobj,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE)
  129. if ((typobj .EQ. 'MOT ') .AND.
  130. & (CHARRE .EQ. 'ESCLAVE')) then
  131. esoplu(iop+10) = .true.
  132. ITABESC = iob
  133. endif
  134. ENDIF
  135. endif
  136. 10 continue
  137. 11 continue
  138. C sauvegarde du nombre d arguments
  139. inbargu = iop-1
  140. C
  141. C recherche de la liste des assistants sur lesquels il faut
  142. C envoyer les donnees
  143. C
  144. if (LOTOUS) then
  145. if (ITABESC .NE. 0) then
  146. mtable = ITABESC
  147. segact mtable
  148. C il faut retenir tous les indices entiers
  149. indtot = mlotab
  150. NASS=indtot
  151. SEGINI,TABASSI
  152. do 30 ind=1,indtot
  153. if (MTABTI(ind) .EQ. 'ENTIER ') then
  154. inbass = inbass + 1
  155. itabass(inbass) = MTABII(ind)
  156. end if
  157. 30 continue
  158. NASS=inbass
  159. C SP On n'ajuste pas car le cout en place est marginal
  160. C SP au regard du cout en temps d'execution
  161. C SP SEGADJ,TABASSI
  162. C** segdes mtable
  163. else
  164. CC print*,'pas de tables esclaves !!'
  165. CC print*,'envoie sur tous les assistants et sur le maitre'
  166. C* inbass = nbesc+1
  167. C* do 32 j=1,inbass
  168. C* itabass(j)=j-1
  169. C* 32 continue
  170. C pv on laisse tomber le maitre pour le moment
  171. NASS=nbesc
  172. SEGINI,TABASSI
  173. do ind=1,NASS
  174. itabass(ind)=ind
  175. enddo
  176. end if
  177. else
  178. NASS = 1
  179. SEGINI,TABASSI
  180. itabass(1)=iproc0
  181. end if
  182. inbass=NASS
  183.  
  184.  
  185. C COMPTE DES RESULTATS ET CREATION DES TABLES
  186. C--------------------------------------------
  187. C combien de résultats ?
  188. C il faut compter correctement les tables
  189. C on ne crée pas d'objets temporaires
  190. nbnomr=nbnom
  191. do 50 inom=1,nbnom
  192. ipos=ITANO1(inom)
  193. if (INOOB2(ITANO1(inom)).eq.'SEPARATE') nbnomr=nbnomr-2
  194. 50 continue
  195. if (LOTOUS) then
  196. do 51 inbres=1,nbnomr
  197. call crtabl(itabres(inbres))
  198. call ecctab(itabres(inbres),'MOT ',IVALIN,XVALIN,
  199. & 'SOUSTYPE',LOGIN,IOBIN,'MOT ',IVALRE,XVALRE,
  200. & 'ESCLAVE',LOGRE,IOBRE)
  201. if (bmaxi) then
  202. call ecctab(itabres(inbres),'MOT ',IVALIN,XVALIN,
  203. & 'CREATEUR',LOGIN,IOBIN,'MOT ',IVALRE,XVALRE,
  204. & 'MAXI ',LOGRE,IOBRE)
  205. elseif (bmini) then
  206. call ecctab(itabres(inbres),'MOT ',IVALIN,XVALIN,
  207. & 'CREATEUR',LOGIN,IOBIN,'MOT ',IVALRE,XVALRE,
  208. & 'MINI ',LOGRE,IOBRE)
  209. elseif (bsouc) then
  210. call ecctab(itabres(inbres),'MOT ',IVALIN,XVALIN,
  211. & 'CREATEUR',LOGIN,IOBIN,'MOT ',IVALRE,XVALRE,
  212. & 'SOUC ',LOGRE,IOBRE)
  213. else
  214. call ecctab(itabres(inbres),'MOT ',IVALIN,XVALIN,
  215. & 'CREATEUR',LOGIN,IOBIN,'MOT ',IVALRE,XVALRE,
  216. & 'ASSIST ',LOGRE,IOBRE)
  217. endif
  218.  
  219. call ecrobj('TABLE ',itabres(inbres))
  220. 51 continue
  221. end if
  222. C
  223. C EXPEDITION DES DONNEES
  224. C-----------------------
  225. C on va enoyer l'instruction sur l'assistant itabass(inbass)
  226. 1122 continue
  227. iproc0 = itabass(inbass)
  228. if (nbesc .eq. 0) then
  229. iproc = 0
  230. else
  231. iproc = mod(iproc0-1,nbesc)+1
  232. end if
  233. if (iproc .eq.0) LOTRMA = .true.
  234. if (inbass .ne. 0) then
  235. segini, mescla=mescl1
  236. MLMOTS = ipcar1
  237. segini, MLMOT1=MLMOTS
  238. segdes MLMOT1,MLMOTS
  239. jpcar1 = MLMOT1
  240. else
  241. mescla = mescl1
  242. end if
  243. mesins=mescl(iproc)
  244. SEGACT MESINS*MOD
  245. NINS = lismes(/1)
  246. IF ( nbins .eq. nins) then
  247. nins = nins + 5
  248. segadj MESINS
  249. END IF
  250. NBINS = NBINS + 1
  251. C JYY print*, 'NBINS,iproc,mescla' , NBINS , iproc, mescla
  252. C** call savseg ( mescla )
  253. LISMES(NBINS) = MESCLA
  254. SEGDES MESINS*RECORD
  255. C decryptage des tables esclaves
  256. if (ITABESC .NE. 0) then
  257. do 130 iop=1,inbargu
  258. if (esoplu(iop+10)) then
  259. itab = esopva(iop+10)
  260. typobj = ' '
  261. call acctab(itab,'ENTIER ',iproc0,XVALIN,CHARIN,
  262. & LOGIN,IOBIN,typobj,IVALRE,XVALRE,CHARRE,
  263. & LOGRE,IOBRE)
  264. if (typobj .ne. ' ') then
  265. esoplu(iop+10) = .false.
  266. esopty(iop+10)=typobj
  267. if (typobj .eq. 'ENTIER ') then
  268. esopva(iop+10)=IVALRE
  269. elseif (typobj .eq. 'LOGIQUE ') then
  270. esoplo(iop+10)=LOGRE
  271. elseif (typobj .eq. 'FLOTTANT') then
  272. esopre(iop+10)=XVALRE
  273. elseif (typobj .eq. 'MOT ') then
  274. esopch(iop+10)=CHARRE
  275. esopva(iop+10)=len(CHARRE)
  276. else
  277. esopva(iop+10)=IOBRE
  278. end if
  279. else
  280. C JYY print*,'assistant non repertorie dans la table ESCLAVE'
  281. interr(1)=iproc0
  282. CALL ERREUR (914)
  283. end if
  284. end if
  285. 130 continue
  286. end if
  287.  
  288. C on colle les resultats
  289. do 140 inom=1,nbnomr
  290. segini mesres
  291. C Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
  292. C ESIsou=mbsouc
  293. LOREMP = .FALSE.
  294. segini nesres
  295. if (iproc.ne.0) then
  296. C write (6,*) ' assist segdes record nesres ',nesres
  297. segdes nesres*record
  298. else
  299. C write (6,*) ' assist segdes nesres ',nesres
  300. segdes nesres
  301. endif
  302. IESRES = nesres
  303. esrees(nbnomr-inom+1)=mesres
  304. segdes mesres
  305. if (LOTOUS) then
  306. call ecctab(itabres(inom),'ENTIER ',iproc0,XVALIN,
  307. & CHARIN,LOGIN,IOBIN,'ESCLAVE ',IVALRE,XVALRE,
  308. & CHARRE,LOGRE,mesres)
  309. else
  310. call ecrobj('ESCLAVE ',mesres)
  311. end if
  312. 140 continue
  313. do 150 inom=nbnomr+1,100
  314. esrees(inom)=0
  315. 150 continue
  316. C transfert du mescla
  317. segdes mescla
  318.  
  319. C passage a l assistant suivant si necessaire
  320. if (inbass .ne. 1) then
  321. inbass = inbass-1
  322. goto 1122
  323. end if
  324.  
  325. C suppression du segment TABASSI ?
  326. SEGSUP,TABASSI
  327.  
  328. C* LODESL = .FALSE.
  329. call setass(0)
  330.  
  331. end
  332.  
  333.  

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