Télécharger assist.eso

Retour à la liste

Numérotation des lignes :

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

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