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

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