Télécharger assist.eso

Retour à la liste

Numérotation des lignes :

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

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