Télécharger la plaquette Cast3M


fr en

Télécharger cquoi.eso

Retour à la liste

Numérotation des lignes : 

cquoi

  1. C CQUOI     SOURCE    CB215821  24/07/17    21:15:04     11961          
  2.       SUBROUTINE CQUOI(MCHAR,ITYPE,IVAL,RVAL,CVAL,LVAL,IOBJ)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C
  6. C   a partir d'un nom dans la chaine MCHAR(<500caracteres)
  7. C   fournit l'objet qui y est attache si cela est possible
  8. C   SI ITYPE n'est pas blanc on impose le type de l'objet
  9. C   attendu (erreur sinon)
  10. C en sortie ; ITYPE type de l'objet
  11. C             IVAL RVAL CVAL LVAL IOBJ donne la valeur
  12. C             associee dans le cas d'entier, de flottant, de mot
  13. C             de logique ou d'objet
  14. C
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. -INC CCNOYAU
  19. -INC CCREDLE
  20. -INC SMBLOC
  21. -INC SMTABLE
  22. -INC CCASSIS
  23.  
  24.       CHARACTER*(*) MCHAR,CVAL
  25.       CHARACTER*8 ITYPE,LTYPE,JTYPE,ITYP1
  26.       CHARACTER*(8) INDIC1 ,TYPOBJ ,MOTYP,CHARRE
  27. *     CHARACTER*(LOCHAI) CMTEXT
  28.       LOGICAL LVAL,ICOND,IBOOL
  29.       ICOND=.FALSE.
  30.       IF(ITYPE.NE.'        ') ICOND=.TRUE.
  31.       ITYP1=ITYPE
  32.       IF(ITYPE.EQ.'FLOTTANT') ITYP1='ENTIER  '
  33.       LECTAB=0
  34.       IF(ITYPE.EQ.'TABLE   ') THEN LECTAB=1
  35.       CRIT = 1.D0 / 3.D0
  36.       CRAT =ABS( CRIT * 3.D0 - 1.d0 )* 1000.
  37. C-- ON SAUVE TEXT DE FACON A LE SURCHARGER TEMPORAIREMENT
  38. *      CMTEXT(1:500)=TEXT(1:500)
  39. *      NRAN1=NRAN
  40. *      ICOUR1=ICOUR
  41. *      IFINA1=IFINAN
  42. *      IPREC1=IPREC
  43.       segini sredle
  44. C-- ON PLACE L'OBJET DE TYPE TEXTE DANS TEXT
  45.       LENI=LEN(MCHAR)
  46.       TEXT(1:500)=MCHAR(1:LENI)
  47.       NRAN= 0
  48.       IPREC=1
  49.       IFINAN=LENI
  50.       ICOUR=LENI
  51.       INSTAB=0
  52.       KER=0
  53. *      write(6,*) ' avant appel redlec text', text(1:20)
  54.       CALL REDLEC(sredle)
  55.       IF(IRE.EQ.0) THEN
  56.         CALL ERREUR(21)
  57.       ENDIF
  58. *      write(6,*) ' ire ', ire
  59. C IRE = 0 FIN DE PHRASE
  60. *      write(6,*) MOT(1:20)
  61.       CALL PRENOM(IPLAMO,0,sredle)
  62.       LTYPE=INOOB2(IPLAMO)
  63.       IPLAFI=IOUEP2(IPLAMO)
  64. *      write(6,*) iplamo,ltype,iplafi
  65.       MTABLE=IOUEP2(IPLAMO)
  66.    25 CONTINUE
  67.       IF(LTYPE.EQ.'TABLE  '.OR.LTYPE.EQ.'OBJET   ')THEN
  68. *          write(6,*) ' on a bien trouve une table ou un objet'
  69.         CALL REDLEC(sredle)
  70.         IF(IRE.EQ.0) THEN
  71.           GO TO 500
  72.         ENDIF
  73.         CALL PRENOM(IPLAMA,0,sredle)
  74.         JTYPE=INOOB2(IPLAMA)
  75. *         write(6,*) ' jtype ',jtype
  76.         IF( JTYPE.EQ.'SEPARATE'.OR.JTYPE.EQ.'METHODOL')THEN
  77.            CALL REDLEC(sredle)
  78.            IF(IRE.EQ.0) THEN
  79.               KER=1
  80.               GO TO 500
  81.            ENDIF
  82. *            write(6, *) 'ire au deuxieme appel redlec', ire
  83.            CALL PRENOM (IPLAMA,0,sredle)
  84.            INDIC1=INOOB2(IPLAMA)
  85.            INDIC2=IOUEP2(IPLAMA)
  86.            SEGACT MTABLE
  87.            NB=MLOTAB
  88.            IF(NB.EQ.0)  THEN
  89.               KER=1
  90.               GOTO 500
  91.            ENDIF
  92.            TYPOBJ=' '
  93.            MOTYP='MOT'
  94.            CALL ACCTAB(MTABLE,MOTYP,IVAL,XER,'SOUSTYPE',IBOOL
  95.      $     ,IOBJ,TYPOBJ,IVALRE,XER,CHARRE,IBOOL,IOBRE)
  96.            IBOOL=.FALSE.
  97.            IF(TYPOBJ.EQ.'MOT     '.AND.CHARRE.EQ.'RESULTAT')
  98.      $     IBOOL=.TRUE.
  99.            DO 10 IJ=1,NB
  100.            IF (INDIC1.NE.MTABTI(IJ)) GOTO 10
  101.            IF (INDIC1.NE.'FLOTTANT') THEN
  102.              IF (INDIC2.NE.MTABII(IJ)) GOTO 10
  103.            ELSE
  104.              IF (IBOOL) THEN
  105.                XER=ABS((XIFLOT(INDIC2)-RMTABI(IJ))/
  106.      $         (ABS(XIFLOT(INDIC2))+MAX(1.D-20 ,ABS(XIFLOT(INDIC2))
  107.      $         )/ 1.D15))
  108.                IF(XER. GT . CRAT )  GO TO 10
  109.              ELSE
  110.                IF (XIFLOT(INDIC2).NE.RMTABI(IJ)) GOTO 10
  111.              ENDIF
  112.            ENDIF
  113.            GOTO 20
  114.   10       CONTINUE
  115. C   pas d'indice dans la table
  116.            KER=1
  117.            GO TO 500
  118.   20       LTYPE=MTABTV(IJ)
  119.            IF (LTYPE.NE.'FLOTTANT') THEN
  120.              IPLAFI=MTABIV(IJ)
  121.            ELSE
  122. *  SYNTONISER LA VALEUR AVEC LA PILE DES FLOTTANTS
  123.              XXVA=RMTABV(IJ)
  124.              DO 1000 J=1,LMNREE
  125.              IF(XIFLOT(J).NE.XXVA) GO TO 1000
  126. C LA VALEUR EXISTE DEJA  EN J IEME POSITION
  127.              IPLAFI=J
  128.              GO TO 1100
  129.  1000        CONTINUE
  130. C LA VALEUR N'EXISTE PAS
  131.              LMNREE=LMNREE+1
  132.              if( nbesc.ne.0) SEGDES,IPILOC
  133.              segact ipiloc*mod
  134.              IL=XIFLOT(/1)
  135.              IF(LMNREE.GT.IL) THEN
  136.                LMxx=LMNREE+100
  137.                lmmm=ichara(/1)
  138.                lmcc=ipchar(/1)
  139.                lmll=iplogi(/1)
  140.                SEGADJ IPiloc
  141.              ENDIF
  142.              XIFLOT(LMNREE)=XXVA
  143.              IPLAFI=LMNREE
  144.              if( nbesc.ne.0) SEGDES,IPILOC
  145.  1100        CONTINUE
  146.            ENDIF
  147.            SEGDES MTABLE
  148.            MTABLE = IPLAFI
  149.            GO TO 25
  150.         ELSE
  151.            KER=1
  152.            GO TO 500
  153.         ENDIF
  154.       ENDIF
  155.   500 CONTINUE
  156. C
  157. C   on arrive ici avec LTYPE et IPLAFI et KER
  158. C
  159.       IF(KER.EQ.1)  THEN
  160.         IF(ICOND) THEN
  161.           MOTERR(1:8)=ITYPE
  162.           CALL ERREUR(37)
  163.         ELSE
  164.           CALL ERREUR(21)
  165.         ENDIF
  166.         GO TO 3000
  167.       ELSE
  168.         IF(ICOND) THEN
  169.           IF(LTYPE.NE.ITYPE.AND.LTYPE.NE.ITYP1) THEN
  170.             MOTERR(1:8)=ITYPE
  171.             CALL ERREUR(37)
  172.             GO TO 3000
  173.           ENDIF
  174.           IF(LTYPE.NE.ITYPE) THEN
  175.             RVAL=IPLAFI
  176.             GO TO 3000
  177.           ENDIF
  178.         ENDIF
  179.         ITYPE=LTYPE
  180.         IF(ITYPE.EQ.'MOT     ') THEN
  181.           IP=IPLAFI
  182.           ID=IPCHAR(IP)
  183.           IFI=IPCHAR(IP+1)
  184.           CVAL=ICHARA(ID:IFI-1)
  185.           IVAL=MIN(LEN(CVAL),IFI - ID )
  186.         ELSEIF(ITYPE.EQ.'LOGIQUE ') THEN
  187.           LVAL=IPLOGI(IPLAFI)
  188.         ELSEIF(ITYPE.EQ.'FLOTTANT') THEN
  189.           RVAL=XIFLOT(IPLAFI)
  190.         ELSEIF(ITYPE.EQ.'ENTIER  ') THEN
  191.           IVAL=IPLAFI
  192.         ELSE
  193.           IOBJ=IPLAFI
  194.         ENDIF
  195.       ENDIF
  196.  3000 CONTINUE
  197. C
  198. C    on remet la pile de lecture en place
  199. C
  200. *      TEXT(1:500)=CMTEXT(1:500)
  201. *      IFINAN=IFINA1
  202. *      IPREC=IPREC1
  203. *      ICOUR=ICOUR1
  204. *      NRAN=NRAN1
  205.       segsup sredle
  206.       RETURN
  207.       END
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  

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