Télécharger la plaquette Cast3M


fr en

Télécharger rempil.eso

Retour à la liste

Numérotation des lignes : 

rempil

  1. C REMPIL    SOURCE    PV090527  24/01/09    21:15:25     11817          
  2. C  SI DANS LA PILE UNE TTABLE EST SUIVI PAR UN DE SES INDICE ALORS ON
  3. C  REMPLACE L'INDICE PAR LA VALEUR ET ON DIT AVOIR DEJA LU LA TABLE
  4. C  I EST LE RANG DE LA TABLE DANS LA PILE INTERMEDIAIRE
  5. C  IL FAUT QUE LA TABLE SOIT SUIVI D'UN SEPARATEUR PUIS DE L'INDICE
  6. C  ISUCC INDIQUE PAR 1 QUE L'ON A TROUVE UN INDICE
  7. C en entree ISUCC=2 si on a rencontre la syntaxe : % titi    c'est
  8. C a dire qu' il faut mettre devant l'objet qui est dans mobjco
  9. C (segment mbloc)
  10.       SUBROUTINE REMPIL(I,ISUCC)
  11.       IMPLICIT INTEGER(I-N)
  12.       EXTERNAL LONG
  13. -INC CCNOYAU
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMTABLE
  18. -INC SMBLOC
  19. -INC SMCOORD
  20. -INC CCASSIS
  21.       REAL*8 XXVA,XER,CRIT,CRAT
  22.       CHARACTER*(8) INDIC1 ,TYPOBJ ,MOTYP,CHARRE ,INDIC4
  23.       CHARACTER*26 ICHA
  24.       CHARACTER*72 MOTASS
  25.       LOGICAL IBOOL
  26.       LOGICAL LOMISA,ILOREMP
  27.       nth=0
  28.       if (nbesc.ne.0) nth=oothrd
  29. *      write(6,*) ' nth nbesc ', nth,nbesc
  30.       if(nbesc.ne.0) segact ipiloc
  31.       IMETH=ISUCC
  33.       CRIT = 1.D0 / 3.D0
  34.       CRAT =ABS( CRIT * 3.D0 - 1.d0 )* 1000.
  35.       MTABLE=JPOOB4(I)
  36.       I1=I+1
  37.       I2=I+2
  38.       IF(IMETH.EQ.2) THEN
  39.          I1=I
  40.          I2=I+1
  41.          MTABLE=MOBJCO
  42. *         write(6,*) ' rempil imeth mobjco', imeth,mobjco
  43.          IF(MOBJCO.EQ.0) THEN
  44.             CALL ERREUR(863)
  45.             RETURN
  46.          ENDIF
  47.       ENDIF
  48.       INDIC1=JTYOBJ(I1)(1:8)
  49. * TEST DE LA PRESENCE D'UN SEPARATEUR SINON RETOUR
  50.  
  51.       IF(INDIC1.NE.'SEPARATE'.AND.INDIC1.NE.'METHODOL') RETURN
  52.       ICAS=1
  53.       IF(INDIC1.EQ.'METHODOL') ICAS=2
  54.       IF(I1.EQ.IHPILE) RETURN
  55. *      write(6,*) ' rempil icas ',icas
  56.       INDIC1=JTYOBJ(I2)(1:8)
  57.       INDIC2=JPOOB4(I2)
  58.       IF(ICAS.EQ.2.AND.IMETH.EQ.1) THEN
  59. * le type est methode et l'a valeur pointe sur la chaine du nom
  60.           INDIC2=INOOB1(JPOOB2(I2))
  61. *          write(6,*) ' rempil 1  indic2', indic2
  62.           IF(INDIC1.EQ.'MOT     ') THEN
  63.             INDIC2 = JPOOB4(I2)
  64. *          write(6,*) ' rempil 2  indic2', indic2
  65.           ENDIF
  66.           INDIC1='METHODE '
  67.       ENDIF
  68. *      if(icas.eq.2) then
  69. *        write(6,*) ' type indice , valeur',indic1,indic2
  70. *       endif
  71.       SEGACT MTABLE
  72.       NB=MLOTAB
  73.       IF(NB.EQ.0) GO TO   15
  74.       TYPOBJ=' '
  75.       MOTYP='MOT'
  76.       CALL ACCTAB(MTABLE,MOTYP,IVAL,XER,'SOUSTYPE',IBOOL
  77.      $     ,IOBJ,TYPOBJ,IVALRE,XER,CHARRE,IBOOL,IOBRE)
  78.       IBOOL=.FALSE.
  79.       IF(TYPOBJ.EQ.'MOT     '.AND.CHARRE.EQ.'RESULTAT')
  80.      $  IBOOL=.TRUE.
  81. C creation de indic3 pour aider l'optimiseur
  82.       if(nbesc.ne.0) segact ipiloc
  83.       INDIC3=MIN(INDIC2,XIFLOT(/1))
  84.       SEGACT MTABLE
  85.  
  86.       DO 10 IJ=1,NB
  87. *       if( icas.eq.2) then
  88. *         write(6,*) ' rempilindicetypevaleur',MTABTI(IJ),MTABII(IJ)
  89. *       endif
  90.       INDIC4 = MTABTI(IJ)(1:8)
  91.       IF(INDIC4.NE.'METHODE ') THEN
  92.           IF (INDIC1.NE.INDIC4) GOTO 10
  93.       ELSE
  94.           IF(INDIC1.NE.'MOT     '.AND.INDIC1.NE.'METHODE ') GO TO 10
  95.       ENDIF
  96.       IF (INDIC1.NE.'FLOTTANT') THEN
  97.         IF (INDIC2.NE.MTABII(IJ)) GOTO 10
  98.       ELSE
  99.           IF (IBOOL) THEN
  100.           XER=ABS((XIFLOT(INDIC3)-RMTABI(IJ))/
  101.      $   (ABS(XIFLOT(INDIC3))+MAX(1.D-20 ,ABS(XIFLOT(INDIC3))
  102.      $      )/ 1.D15))
  103. *     $  XIFLOT(INDIC2),RMTABI(IJ), XER
  104.          IF(XER. GT . CRAT )  GO TO 10
  105.           ELSE
  106.           IF (XIFLOT(INDIC3).NE.RMTABI(IJ)) GOTO 10
  107.           ENDIF
  108.       ENDIF
  109. *      if(icas.eq.2) write(6,*) 'rempil on a trouve'
  110.       GOTO 20
  111.   10  CONTINUE
  112.   15  CONTINUE
  113. *  PAS D'INDICE CORRECT ON  FAIT UNE ERREUR
  114.       IF(IMETH.EQ.2.AND.ICAS.EQ.2) THEN
  115.              I3=I1
  117.              JTYOBJ(I3)(1:8)='TABLE   '
  118.              JPOOB4(I3)=MOBJCO
  119.              if(nbesc.ne.0) SEGDES,IPILOC
  120.              return
  121.       ELSE
  122.       MOTERR=' '
  123.       IF ( INDIC1.EQ.'FLOTTANT') THEN
  124.          REAERR(1)= XIFLOT(INDIC2)
  125.          CALL ERREUR ( 534)
  126.  
  127.       ELSEIF (INDIC1.EQ.'MOT     ') THEN
  128. CCC ** SI ON NE TROUVE PAS UN MOT ON CHERCHE S'IL N'Y A PAS LE MEME
  129. CCC     MOT SANS LES BLANCS A LA FIN DU MOT
  130. *         write(6,*) ' indic2' ,indic2
  131. *         write(6,*) ' longueur de ipchar' , ipchar(/1)
  132. *         write(6,*) ( ipchar (iou),iou=1,ipchar(/1))
  133.          IOD = IPCHAR(INDIC2 )
  134. *          write(6,*) ' iod ' , iod
  135.          IOF= IPCHAR(INDIC2+1)
  136.  
  137.          IL2= LONG(ICHARA(IOD:IOF-1))+IOD-1
  138.          DO 30 IJ=1,NB
  139.            IP=MTABII(IJ)
  140.            ID=IPCHAR(IP)
  141. **         IFI=IPCHAR(IP+1)
  142. **         IL1= LONG(ICHARA(ID:IFI-1))+ID-1
  143. **         IF(ICHARA(ID:IL1).EQ.ICHARA(IOD:IL2)) GO TO 20
  144.            if (indic2.eq.ip) goto 20
  145.    30    CONTINUE
  146.          MOTERR =ICHARA(IOD:IOF-1)
  147.          CALL ERREUR (535)
  148.       ELSE
  149.          IF(ICAS.EQ.1) THEN
  150.             MOTERR(1:8) = INDIC1
  151.             INTERR(1)= INDIC2
  152.             CALL ERREUR (171)
  153.          ELSEIF(ICAS.EQ.2) THEN
  154.              IF(IMETH.EQ.1) THEN
  155.                 CALL ERREUR(864)
  156.              ELSE
  157.                 CALL ERREUR(865)
  158.              ENDIF
  159.          ENDIF
  160.       ENDIF
  161.       ENDIF
  162.       IF(nbesc.ne.0) SEGDES,IPILOC
  163.       RETURN
  164.   20  CONTINUE
  165. * ON A TROUVE UN INDICE *  si icas=2 et imeth=1 il faut tester que a vale
  166. *  est bien un mot ou une procedur
  167.       segact mtable*mod
  168.       if( nbesc.ne.0) SEGDES,IPILOC
  169.       I3=I2
  171.       INDIC1=MTABTV(IJ)(1:8)
  172.       JTYOBJ(I3)(1:8)=INDIC1
  173.       JPOOB2(I3)=0
  174.       if (indic1.eq.'ESCLAVE ') then
  175.         LOMISA = .FALSE.
  176.         if (.not.lodesl.or.nth.ne.0) lomisa    =.true.
  177.         mesres=MTABIV(IJ)
  178.           if (iimpi .eq. 1234) write(ioimp,*)
  179.      &        'un objet (ESCLAVE) de la table est utilisé',mesres
  180. C *     mise a jour eventuelle et menage eventuel
  181.         IF ( LOMISA ) THEN
  182.           segdes mcoord
  183.           SEGACT MESRES
  184.           if (.not.loremp) then
  185.    5      continue
  186.             segdes mesres*record
  187.             SEGACT MESRES*ECR=1
  188.             if (.not.loremp) then
  189. *             write(6,*) ' loremp pas vrai dans rempil '
  190.              goto 5
  191.             endif
  192.           endif
  193. **          segdes mesres
  194.           segact mcoord
  195.             if (iimpi .eq. 1234)
  196.      &    write(ioimp,*) 'le segment a ete mis a jour ',MESRES
  197.           indic1=esrety
  198.           JTYOBJ(I3)(1:8)=INDIC1
  199.           call tabesc(mtable,ij,mesres)
  200. C *       menage eventuel
  201.           SEGDES MESRES
  202.         END IF
  203.       endif
  204.       IF(IMETH.EQ.1.AND.ICAS.EQ.2) THEN
  205.          IF(INDIC1.NE.'MOT     '.AND. INDIC1.NE.'PROCEDUR') THEN
  207.           if(nbesc.ne.0) SEGDES,IPILOC
  208.           RETURN
  209.          ENDIF
  210.       ENDIF
  211.       IF (INDIC1.NE.'FLOTTANT') THEN
  212.         JPOOB4(I3)=MTABIV(IJ)
  213.       ELSE
  214. *  SYNTONISER LA VALEUR AVEC LA PILE DES FLOTTANTS
  215.         XXVA=RMTABV(IJ)
  216.         call posree(xxva,iplac)
  217.         JPOOB4(I3)=IPLAC
  218.       ENDIF
  219.       SEGDES MTABLE
  220.       IF(ICAS.EQ.1) JPOOB1(I)=.FALSE.
  221.       JPOOB1(I1)=.FALSE.
  222.       IF(IMETH.EQ.2.AND.INDIC1.EQ.'PROCEDUR') THEN
  223. * on place l'objet mobjco dans la pile a la place du %
  224. *       write(6,*) 'rempil on vient de trouver %procedur'
  225.          JPOOB1(I1)=.TRUE.
  226.          JPOOB4(I1)=MOBJCO
  227.          JTYOBJ(I1)(1:8) = 'OBJET   '
  228.       ENDIF
  229.       if(nbesc.ne.0) SEGDES,IPILOC
  230.       RETURN
  231.       END
  232.  
  233.  
  234.  

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