Télécharger la plaquette Cast3M


fr en

Télécharger assist.eso

Retour à la liste

Numérotation des lignes : 

assist

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

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