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    SP204843  26/02/03    21:15:05     12461          
  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.       IK = 0
  153.       TYPLOB = '        '
  154.       if (LOTOUS) then
  155.         if (ITABESC .NE. 0) then
  156. C     write(6,*) 'ASSIST: ITABESC=',ITABESC
  157.            mtable = ITABESC
  158.            segact mtable
  159. C il faut retenir tous les indices entiers
  160.            indtot = mlotab
  161.            NASS=indtot
  162.            SEGINI,TABASSI
  163.            do 30 ind=1,indtot
  164.               if (MTABTI(ind) .EQ. 'ENTIER  ') then
  165.                  inbass = inbass + 1
  166.                  itabass(inbass) = MTABII(ind)
  167.               end if
  168.  30        continue
  169.            NASS=inbass
  170. C SP       On n'ajuste pas car le cout en place est marginal
  171. C SP       au regard du cout en temps d'execution
  172. C SP       SEGADJ,TABASSI
  173. C**        segdes mtable
  174.         else if (ILISTOB .NE. 0) then
  175.           MLOBJE = ILISTOB
  176.           SEGACT, MLOBJE
  177.           TYPLOB = TYPOBJ
  178.           IK = 1
  179.           IF (TYPLOB.EQ.'FLOTTANT') IK = 2
  180.           IF (IK.EQ.1) indtot = LISOBJ(/1)
  181.           IF (IK.EQ.2) indtot = RLIREE(/1)
  182. C     write(6,*) 'ASSIST: MLOBJE, TYPOBJ, NOBJ=',MLOBJE,TYPOBJ,indtot
  183.           NASS=indtot
  184.           SEGINI,TABASSI
  185.           do 40 ind=1,indtot
  186.                 itabass(ind) = ind
  187. C     write(6,*) 'ASSIST: ind, itabass(ind)=',ind,itabass(ind)
  188.  40       continue
  189.         else
  190. CC          print*,'pas de tables esclaves !!'
  191. CC          print*,'envoie sur tous les assistants et sur le maitre'
  192. C*          inbass = nbesc+1
  193. C*          do 32 j=1,inbass
  194. C*             itabass(j)=j-1
  195. C* 32         continue
  196. C pv on laisse tomber le maitre pour le moment
  197.           NASS=nbesc
  198.           SEGINI,TABASSI
  199.           do ind=1,NASS
  200.              itabass(ind)=ind
  201.           enddo
  202.         end if
  203.       else
  204.         NASS = 1
  205.         SEGINI,TABASSI
  206.         itabass(1)=iproc0
  207.       end if
  208.       inbass=NASS
  209.  
  210.  
  211. C COMPTE DES RESULTATS ET CREATION DES TABLES
  212. C--------------------------------------------
  213. C  combien de résultats ?
  214. C  il faut compter correctement les tables
  215. C  on ne crée pas d'objets temporaires
  216.       nbnomr=nbnom
  217.       do 50 inom=1,nbnom
  218.         ipos=ITANO1(inom)
  219.         if (INOOB2(ITANO1(inom)).eq.'SEPARATE') nbnomr=nbnomr-2
  220.   50  continue
  221.       if (LOTOUS) then
  222.         do 51 inbres=1,nbnomr
  223.           if (ILISTOB .NE. 0) THEN
  224.  
  225.             IF (IK.EQ.0) THEN
  226.               write(iimpi,*) 'Dans assist'
  227.               CALL ERREUR(5)
  228.               RETURN
  229.             ENDIF
  230.  
  231.             NOBJ = 0
  232.             NREE = 0
  233.             IF (IK.EQ.1) NOBJ = NASS
  234.             IF (IK.EQ.2) NREE = NASS
  235.             SEGINI, MLOBJ1
  236.             itabres(inbres) = MLOBJ1
  237. C     write(6,*) 'ASSIST : MLOBJ1=',MLOBJ1
  238.             call ecrobj('LISTOBJE',MLOBJ1)
  239.  
  240.           else
  241.  
  242.             call crtabl(itabres(inbres))
  243.             call ecctab(itabres(inbres),'MOT     ',IVALIN,XVALIN,
  244.      &          'SOUSTYPE',LOGIN,IOBIN,'MOT     ',IVALRE,XVALRE,
  245.      &          'ESCLAVE',LOGRE,IOBRE)
  246.             if     (bmaxi) then
  247.               call ecctab(itabres(inbres),'MOT     ',IVALIN,XVALIN,
  248.      &            'CREATEUR',LOGIN,IOBIN,'MOT     ',IVALRE,XVALRE,
  249.      &            'MAXI    ',LOGRE,IOBRE)
  250.             elseif (bmini) then
  251.               call ecctab(itabres(inbres),'MOT     ',IVALIN,XVALIN,
  252.      &            'CREATEUR',LOGIN,IOBIN,'MOT     ',IVALRE,XVALRE,
  253.      &            'MINI    ',LOGRE,IOBRE)
  254.             elseif (bsouc) then
  255.               call ecctab(itabres(inbres),'MOT     ',IVALIN,XVALIN,
  256.      &            'CREATEUR',LOGIN,IOBIN,'MOT     ',IVALRE,XVALRE,
  257.      &            'SOUC    ',LOGRE,IOBRE)
  258.             else
  259.               call ecctab(itabres(inbres),'MOT     ',IVALIN,XVALIN,
  260.      &            'CREATEUR',LOGIN,IOBIN,'MOT     ',IVALRE,XVALRE,
  261.      &            'ASSIST  ',LOGRE,IOBRE)
  262.             endif
  263.             call ecrobj('TABLE   ',itabres(inbres))
  264.  
  265.           endif
  266.   51    continue
  267.       end if
  268. C
  269. C EXPEDITION DES DONNEES
  270. C-----------------------
  271. C on va enoyer l'instruction sur l'assistant itabass(inbass)
  272.  1122 continue
  273.       iproc0 = itabass(inbass)
  274.       if (nbesc .eq. 0) then
  275.         iproc = 0
  276.       else
  277.         iproc = mod(iproc0-1,nbesc)+1
  278.       end if
  279.       if (iproc .eq.0) LOTRMA = .true.
  280.       if (inbass .ne. 0) then
  281.             segini, mescla=mescl1
  282.             MLMOTS = ipcar1
  283.             segini, MLMOT1=MLMOTS
  284.             segdes MLMOT1,MLMOTS
  285.             jpcar1 = MLMOT1
  286.       else
  287.             mescla = mescl1
  288.       end if
  289.         mesins=mescl(iproc)
  290.         SEGACT MESINS*MOD
  291.         NINS = lismes(/1)
  292.         IF ( nbins .eq. nins) then
  293.            nins = nins + 5
  294.            segadj MESINS
  295.         END IF
  296.         NBINS = NBINS + 1
  297. C JYY        print*, 'NBINS,iproc,mescla' , NBINS , iproc, mescla
  298. C**     call savseg ( mescla )
  299.         LISMES(NBINS) = MESCLA
  300.         SEGDES MESINS*RECORD
  301. C decryptage des tables esclaves
  302.       if (ITABESC .NE. 0) then
  303.          do 130 iop=1,inbargu
  304. C     write(6,*) 'ASSIST:esoplu(iop+10),inbargu=',esoplu(iop+10),inbargu
  305.             if (esoplu(iop+10)) then
  306.                itab = esopva(iop+10)
  307. C     write(6,*) 'ASSIST: itab=',itab
  308.                typob = '        '
  309.                call acctab(itab,'ENTIER  ',iproc0,XVALIN,CHARIN,
  310.      &                  LOGIN,IOBIN,typob,IVALRE,XVALRE,CHARRE,
  311.      &                  LOGRE,IOBRE)
  312.                if (typob .ne. '        ') then
  313.                  esoplu(iop+10) = .false.
  314.                  esopty(iop+10)=typob
  315.                  if (typob .eq. 'ENTIER  ') then
  316.                     esopva(iop+10)=IVALRE
  317.                  elseif (typob .eq. 'LOGIQUE ') then
  318.                     esoplo(iop+10)=LOGRE
  319.                  elseif (typob .eq. 'FLOTTANT') then
  320.                     esopre(iop+10)=XVALRE
  321.                  elseif (typob .eq. 'MOT     ') then
  322.                     esopch(iop+10)=CHARRE
  323.                     esopva(iop+10)=len(CHARRE)
  324.                  else
  325. C     write(6,*) 'ASSIST: iproc0, typob, IOBRE=',iproc0,typob,IOBRE
  326.                     esopva(iop+10)=IOBRE
  327.                  end if
  328.                else
  329. C JYY             print*,'assistant non repertorie dans la table ESCLAVE'
  330.                   interr(1)=iproc0
  331.                   CALL ERREUR (914)
  332.                endif
  333.             endif
  334.  130     continue
  335.  
  336.       else if (ILISTOB .NE. 0) then
  337.          do 135 iop=1,inbargu
  338. C     write(6,*) 'ASSIST:esoplu(iop+10),inbargu=',esoplu(iop+10),inbargu
  339.             if (esoplu(iop+10)) then
  340.                mlobj2 = esopva(iop+10)
  341.                segact mlobj2
  342.                esoplu(iop+10) = .false.
  343.                esopty(iop+10) = mlobj2.typobj
  344.                ik = 1
  345.                if ((mlobj2.typobj).EQ.'FLOTTANT') ik = 2
  346.                if (ik.EQ.1) esopva(iop+10) = mlobj2.LISOBJ(iproc0)
  347.                if (ik.EQ.2) esopre(iop+10) = mlobj2.RLIREE(iproc0)
  348. C     write(6,*) 'ASSIST: iproc0,mlobj2, typobj=',iproc0,mlobj2,
  349. C    &  mlobj2.typobj
  350.             endif
  351.  135     continue
  352.       endif
  353.  
  354. C on colle les resultats
  355.          do 140 inom=1,nbnomr
  356.            segini mesres
  357.            LOREMP = .FALSE.
  358.            if (iproc.ne.0) then
  359. C          write (6,*) ' assist segdes record mesres ',mesres
  360.              segdes mesres*record
  361.            else
  362. C          write (6,*) ' assist segdes mesres ',mesres
  363.              segdes mesres
  364.            endif
  365.            esrees(nbnomr-inom+1)=mesres
  366. C     write(6,*) 'ASSIST : iproc0,nbnomr, mesres=',iproc0,nbnomr,mesres
  367.            if (LOTOUS) then
  368.             if (ILISTOB .NE. 0) then
  369.               mlobj1.typobj         = 'ESCLAVE'
  370.               mlobj1.lisobj(iproc0) = mesres
  371.             else
  372.               call ecctab(itabres(inom),'ENTIER  ',iproc0,XVALIN,
  373.      &               CHARIN,LOGIN,IOBIN,'ESCLAVE ',IVALRE,XVALRE,
  374.      &               CHARRE,LOGRE,mesres)
  375.              endif
  376.            else
  377.              call ecrobj('ESCLAVE ',mesres)
  378.            endif
  379.  140     continue
  380.          do 150 inom=nbnomr+1,100
  381.             esrees(inom)=0
  382.  150     continue
  383. C transfert du mescla
  384.        segdes mescla
  385.  
  386. C passage a l assistant suivant si necessaire
  387.       if (inbass .ne. 1) then
  388.         inbass = inbass-1
  389.         goto 1122
  390.       end if
  391.  
  392. C suppression du segment TABASSI ?
  393.       SEGSUP,TABASSI
  394.  
  395. C*    LODESL = .FALSE.
  396.       call setass(0)
  397.  
  398.       end
  399.  
  400.  
  401.  
  402.  
  403.  
  404.  
  405.  
  406.  
  407.  

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