Télécharger la plaquette Cast3M


fr en

Télécharger proced.eso

Retour à la liste

Numérotation des lignes : 

proced

  1. C PROCED    SOURCE    PV090527  24/01/09    21:15:22     11817          
  2.       SUBROUTINE PROCED
  3.  
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMBLOC
  11. -INC CCNOYAU
  12. -INC CCREDLE
  13. -INC SMTABLE
  14. -INC CCASSIS
  15. -INC TMCOLAC
  16. -INC CCPERF
  17.  
  18.       SEGMENT IVAL(2*NARG)
  19.       SEGMENT MTYYYB
  20.          CHARACTER*(8) MTYYYA(NARG)
  21.       ENDSEGMENT
  22.       SEGMENT ITITE3
  23.          INTEGER ITITEN(NIS), IOU(NIS)
  24.         CHARACTER*(8) ITITEM(NIS)
  25.       ENDSEGMENT
  26.  
  27.       INTEGER ITTIME(4)
  28.  
  29.       CHARACTER*8 MCOTA,TYPOBJ,CHARRE
  30.       CHARACTER*(LONOM) cnompr
  31.       CHARACTER*4 CHA4
  32.       CHARACTER*72 MTYTA
  33.       REAL*8 XRE
  34.       LOGICAL LOGI,LOGR1,lodes0
  35.       CHARACTER*4 MDEB(2),CHA1
  36.       INTEGER CRET
  37.       DATA MDEB/'DEBP','DEBM'/
  38.  
  39.        sredle=iredle
  40. *       write(6,*) ' entreee dans proced  lmnnom ' , lmnnom
  41. *      if(iimpi.eq.1876) write(6,*) ' proced avant appel dune proc'
  42.       CALL LIROBJ('PROCEDUR',IARGO,1,IRETOU)
  43.       IARGUM= IPIPR1(IARGO)
  44.  
  45. *     if(iimpi.eq.1754) then
  46.       call quenom(cnompr)
  47. *     write(6,*) ' nom de la procedure ' , cnompr,IARGO
  48. *     endif
  49.  
  50.  
  51. C     DEBUT Duree passee dans les procedures (Voir FINPRO pour la sortie)
  52.       call timespv(ittime,oothrd)
  53.       IELAPS=ITTIME(1) + ITTIME(2)
  54.       ICPU  =ITTIME(3) + ITTIME(4)
  55.  
  56. C     Initialisation eventuelle des Duree passee dans les procedures
  57.       IF(ITPSPR .EQ. 0)THEN
  58.         NBBLOC=1
  59.         NIVMAX=10
  60.         SEGINI,ITPSBL
  61. C       Mise dans le COMMON SMPERF
  62.         ITPSPR=ITPSBL
  63. C       Protection du MENAGE
  64.         CALL SAVSEG(ITPSBL)
  65.         NICOU =1
  66.         ITPSBL.CDPROC(NBBLOC)  = cnompr
  67.         II    =1
  68.  
  69.       ELSE
  70.         ITPSBL = ITPSPR
  71.         SEGACT,ITPSBL*MOD
  72.         NICOU =ITPSBL.NIVCOU
  73.  
  74.         IF(NICOU .GT. 0)THEN
  75. C         Incremente la duree de la procedure qu'on va quitter
  76.           II=ITPSBL.IPRONI(NICOU)
  77.           ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
  78.      &                       (IELAPS - ITPSBL.TPSPRO(1,II))
  79.           ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
  80.      &                       (ICPU   - ITPSBL.TPSPRO(2,II))
  81.         ENDIF
  82.  
  83.         NICOU =NICOU + 1
  84.         NBBLOC=ITPSBL.NBAPRO(/1)
  85.         DO II=1,NBBLOC
  86.           IF(cnompr .EQ. ITPSBL.CDPROC(II)) GOTO 11
  87.         ENDDO
  88. C       Ajout de la procedure
  89.         NBBLOC = NBBLOC + 1
  90.         NIVMAX = ITPSBL.IPRONI(/1)
  91.         SEGADJ,ITPSBL
  92.         ITPSBL.CDPROC(NBBLOC)  = cnompr
  93.         II = NBBLOC
  94.  
  95.  11     CONTINUE
  96.         IF(NICOU .GT. NIVMAX)THEN
  97.           NIVMAX=NICOU * 2 + 10
  98.           SEGADJ,ITPSBL
  99.         ENDIF
  100.       ENDIF
  101.  
  102.       ITPSBL.NIVCOU       = NICOU
  103.       ITPSBL.IPRONI(NICOU)= II
  104.       ITPSBL.TPSPRO(1,II) = IELAPS
  105.       ITPSBL.TPSPRO(2,II) = ICPU
  106.       ITPSBL.NBAPRO(II)   = ITPSBL.NBAPRO(II) + 1
  107. C     FIN Duree passee dans les procedures
  108.  
  109.       MBLO1=IARGUM
  110. **      write(6,*) 'mblo1 en 110 ',mblo1
  111.       IF(IERR.NE.0) RETURN
  112.       IF(IIMPI.EQ.1754) WRITE(IOIMP,965) IARGUM
  113.   965 FORMAT('  DANS PROCED VALEUR DE IARGUM ',I8)
  114. *  LA FIN DU IF EST MISE EN COMMENTAIRE
  115.       IF(IARGUM.LT.0) THEN
  116.         CALL PROCPO(-IARGUM,CRET)
  117. **      write(6,*) ' cret apres procpo ',cret
  118.         IF(CRET .NE. 99999) CALL ERREUR(5)
  119.         IF (IERR.NE.0) RETURN
  120.         IOLEC=-IOLEC
  121.         IECHA=IECHO
  122.         IECHO=max( 0,iecho - 1)
  123. C  SAUVETAGE DU TYPE DES OBJETS TEMPORAIRE
  124.         ITITE=0
  125.         IF(IPTEM.NE.0) THEN
  126.           ITITE=1
  127.           MOT(1:8)='#'
  128.           IRE=3
  129.           NIS=IPTEM
  130.           SEGINI ITITE3
  131.           DO 112 I=1,IPTEM
  132.           IF(I.LT.10)THEN
  133.             WRITE(MOT(2:2),FMT='(I1)')I
  134.             NCAR=2
  135.           ELSE
  136.             WRITE(MOT(2:3),FMT='(I2)')I
  137.             NCAR=3
  138.           ENDIF
  139.           IAVA=0
  140.           CALL PRENOM(IPLAMO,IAVA,sredle)
  141.           ITITEN(I)=IPLAMO
  142.           ITITEM(I)=INOOB2(IPLAMO)
  143.           IOU(I)=IOUEP2(IPLAMO)
  144.   112     CONTINUE
  145.         ENDIF
  146. C  FIN DU SAUVETAGE
  147.         CALL PROCSA
  148.         IPTEM=0
  149.         MBFONC=1
  150.         MSABL=MBLSUP
  151.         MBLSUP=0
  152. C        IRZTC=0
  153. *         If(iimpi.eq.1876) write(6,*) ' proced avant appel lirmot'
  154.         CALL LIRMOT(MDEB,2,IRET,1)
  155. *         If(iimpi.eq.1876)write(6,*)' proced apres lirmot iret',iret
  156.         IF(IERR.NE.0) RETURN
  157.         MBLSUP=MSABL
  158.         CHA4=LOCERR(1:4)
  159.         LOCERR(1:4)=MDEB(IRET)
  160. *        write(6,*) ' appel mapr lmnnom ', lmnnom
  161.         CALL MAPR(IRET)
  162. *        write(6,*) ' sorteri mapr lmnnom', lmnnom
  163.         LOCERR(1:4)=CHA4
  164.         IF(IERR.NE.0) RETURN
  165. C
  166. C  *** ON REMET LES TYPES DES OBJETS TEMPORAIRES
  167. C
  168. *         write(6,*) ' iouep2(/1) ',iouep2(/1)
  169.         IF(ITITE.NE.0) THEN
  170.           DO 113 I=1,ITITEN(/1)
  171.           IPLAMO=ITITEN(I)
  172. *          write(6,*) ' iplamo ' , iplamo
  173.           INOOB2(IPLAMO)=ITITEM(I)
  174.           IOUEP2(IPLAMO)=IOU(I)
  175.  113      CONTINUE
  176.           SEGSUP ITITE3
  177.         ENDIF
  178.         IECHO=IECHA
  179.         IOLEC=ABS(IOLEC)
  180.         MBLO1=IPIPR1(IARGO)
  181.         if (mblo1.lt.0) then
  182.          moterr(1:24)=cnompr
  183.          call erreur(1141)
  184.          return
  185.         endif
  186. **      write(6,*) 'mblo1 en 181 ',mblo1
  187.         CALL PROCRE
  188.       ENDIF
  189. *  FIN DU IF  ICI  ICI ICI  ICI  ICI
  190. C  ON ACTIVE LE SEGMENT DONNANT LES ARGUMENTS ,
  191. *      write(6,*) ' lmnnom ' , lmnnom
  192.       SEGACT MBLO1
  193. *      write(6,*) ' mdeobj mfiobj  lmnnom ' , mblo1.mdeobj,
  194. *     $ mblo1.mfiobj,lmnnom
  195.       IARGUM=MBLO1.MARGUM
  196.       SEGACT IARGUM
  197. *      write(6,*)'ent proced lmnnom mdeobj mfiobj',lmnnom,mdeobj,mfiobj
  198. C  ON LIT LES ARGUMENTS  ON SAUVE LEURS VALEURS DANS IVAL
  199.       NARG= MTYARG(/2)
  200.       IOPRME=MTXMET
  201.       IF(IIMPI.EQ.1754) WRITE(6,4834) IARGUM,NARG
  202.  4834 FORMAT('  PROCED :  IARGUM   NARG',2I5)
  203.       IF(IOPRME.EQ.2) THEN
  204. C on est en presence d'une methode, il faut lire l'objet sur lequel elle
  205. C s'applique
  206.         CALL LIROBJ('OBJET   ', IRETCO,1,IRETOU)
  207.         IF(IERR.NE.0) RETURN
  208.       ENDIF
  209.       IF(NARG.NE.0) THEN
  210.         SEGINI IVAL ,MTYYYB
  211.         DO 1 I =1,NARG
  212.           II       = 2 * I - 1
  213.           MCOTA    = MTYARG(I)
  214.           MTYYYA(I)= MCOTA
  215.           ICOND    = IOBLIG(I)
  216.  
  217.           IF(MCOTA.EQ.'FLOTTANT') THEN
  218.             CALL LIRREE(XRE,ICOND,IRETOU)
  219. C           CB215821 : Les arguments de type FLOTTANTS facultatifs non fournis sont NAN !!!
  220.             IF(IRETOU .NE. 0) THEN
  221.               CALL QUERAN(IRAT,MCOTA,IRET,XRE,CHA1,LOGI,IOB)
  222.             ENDIF
  223.  
  224.           ELSEIF(MCOTA.EQ.'TABLE   ')THEN
  225.             IFICHA=ILTYPA(I)
  226.             IF(IFICHA.NE.0) THEN
  227.               MTYTA= MSTYPA(I)
  228.               CALL LIRTAB( MTYTA(1:IFICHA),IRAT,ICOND,IRETOU)
  229.             ELSE
  230.               CALL LIROBJ('TABLE   ',IRAT,ICOND,IRETOU)
  231.             ENDIF
  232.  
  233.           ELSE
  234.             CALL LIRTAB('ESCLAVE',IRAT,0,IRETOU)
  235.             IF (IRETOU .EQ. 1)THEN
  236. C               On a lu une TABLE 'ESCLAVE', vérification que le TYPE de l'OBJET est bon
  237.  
  238.               MTABLE=IRAT
  239.               IND    = 1
  240.               TYPOBJ =' '
  241.               lodes0 = lodesl
  242.               lodesl = .FALSE.
  243.               CALL ACCTAB(MTABLE,'ENTIER',IND   ,0.D0  ,'  ',.TRUE.,0,
  244.      &                           TYPOBJ,IVALRE,XVALRE,CHARRE,LOGR1 ,ID1)
  245.               IF (IERR.NE.0) RETURN
  246.               lodesl=lodes0
  247.  
  248. C               Il faut que le type corresponde au type de l''objet initialement demande
  249.               IF(TYPOBJ .EQ. MCOTA)THEN
  250.                 MTYYYA(I)= 'TABLE   '
  251.               ELSE
  252.                 MOTERR(1:8 )=MCOTA
  253.                 MOTERR(9:16)=TYPOBJ
  254.                 CALL ERREUR(1045)
  255.                 RETURN
  256.               ENDIF
  257.  
  258.             ELSE
  259. C             On lit un objet normalement
  260.               MOTERR(1:8) =MCOTA
  261.               MOTERR(9:33)=cnompr
  262.               CALL MESLIR(1121)
  263.               CALL LIRABJ(MCOTA,IRAT,ICOND,IRETOU)
  264.               MTYYYA(I)= MCOTA
  265.             ENDIF
  266.           ENDIF
  267.  
  268.           IF(IERR.NE.0) THEN
  269.             SEGDES MBLO1,IARGUM
  270.             RETURN
  271.           ENDIF
  272.           IF(IRETOU.EQ.0) THEN
  273.             IVAL(II)=0
  274.           ELSE
  275.             IVAL(II)=1
  276.             IVAL(II+1)=IRAT
  277.           ENDIF
  278.           IF(IIMPI.EQ.1754) THEN
  279.             WRITE(IOIMP,FMT='('' ARGUMENT TYPE EXIS POINTEUR'',A8,2I6)')
  280.      $        MTYARG(I),IVAL(II)
  281.           ENDIF
  282.    1    CONTINUE
  283.       ENDIF
  284.  
  285.       MTXBI3 = MTXBB
  286.       MTXFL3 = MTXFLO
  287. C  ON ECRIT LES ARGUMENTS DANS LA PILE DES OBJETS
  288. C    AU PREALABLE SAUVETAGE LECTURE ET ACTIVATION DU BLOC
  289.       CALL PROCSA
  290.       MTEM  =MBLOC
  291.       MTXBLC=MTXBL
  292.       IF(MTXBL.NE.0) SEGDES MTXBLC
  293.       ISSPOT=ISPOTE
  294.       SEGDES ISSPOT
  295.       SEGDES MBLOC
  296.       SEGINI,MBLOC=MBLO1
  297.       lmnlon=mfiobj-mdeobj
  298.       mdeobj=lmnnom+1
  299.       mfiobj=mdeobj+lmnlon
  300. *      write(6,*)'sor proced lmnlon mdeobj mfiobj',lmnnom,mdeobj,mfiobj
  301.       lmnnom=mfiobj
  302.       n=iouep2(/1)
  303.       if( n.lt.lmnnom) then
  304.         n=lmnnom+100
  305.         segadj,itabob,itaboc,itabod
  306.       endif
  307.       ISSPOT=ISPOTE
  308.       SEGDES ISSPOT
  309.       NVQTEM=20
  310.       SEGINI ISSPOT
  311.       ISPOTE=ISSPOT
  312.       SEGDES MBLO1
  313.       MBLSUP=MTEM
  314.       MBLPRO=MBLO1
  315.       MTXBLC=MTXBL
  316. C     Le nom du compteur de boucle (&BOUCLE) est utilise pour le nom de la procedure
  317.       NCONBO=cnompr
  318.  
  319.       IF(IOPRME.EQ.2) THEN
  320.         MOBJCO=IRETCO
  321.       ENDIF
  322.       IF(MTXBL.NE.0) SEGACT MTXBLC
  323.       MBFONC=0
  324.       MBCOUR=0
  325. C      IPSI =0
  326.       MBERR =0
  327.       MBCONT=1
  328. C
  329. C  ****  ON MET DE COTE LA VALEUR DE LA PILE AFFECTEE A LA PROCEDURE
  330. C        EN VUE DU RECURSIF
  331. *      NBMOT= MFIOBJ-MDEOBJ+1
  332. *      SEGINI MSAPI3
  333. *      MSAPII=MSAPI3
  334. *      DO 252 J=1,NBMOT
  335. *      MSAPIJ(J)=INOOB1(MDEOBJ-1+J)
  336. *      MSAPIL(J)=INOOB2(MDEOBJ-1+J)
  337. *      MSAPIN(J)=IOUEP2(MDEOBJ-1+J)
  338. *  252 CONTINUE
  339. *      SEGDES MSAPI3
  340. C REMISE DES NOMS DES OBJETS DE LA PROCEDURE  ET DE LEUR TYPES
  341.       SEGACT MTXBI3
  342.       J=0
  343. C     JLO=MTXBI(/1)
  344. *     write(6,*) ' proced remise en etat de inoob1 mdeobj' , mdeobj
  345.       DO 154 I=MDEOBJ,MFIOBJ
  346.         J= J + 1
  347.         INOOB1(I)=MTXBI(J)
  348.         inoob2(i)=mtxbd(j)
  349.         IOUEP2(i)=mtxbe(j)
  350. *       write(6,*) ' i, inoob ' , i , inoob1(i),inoob2(i),iouep2(i)
  351.  154  CONTINUE
  352. C REMISE DES VALEURS DES FLOTTANTS
  353.       IF( MTXFLO.NE.0) THEN
  354.         SEGACT MTXFL3
  355.         NREE = MITFLO(/1)
  356.         IF ( NREE . NE . 0) THEN
  357.           CALL POSCHA('##BID##',IPOSCH)
  358.           DO 155 I=1,NREE
  359.           NOMBID=INOOB1(MITFLO(I)+mdeobj-1)
  360.           INOOB1(MITFLO(I)+mdeobj-1)=IPOSCH
  361.           XRE = XTFLO(I)
  362.           CALL NOMREE ('##BID##',XRE)
  363.           INOOB1(MITFLO(I)+mdeobj-1)=NOMBID
  364.   155        CONTINUE
  365.         ENDIF
  366.         SEGDES MTXFL3
  367.       ENDIF
  368. C INITIALISATION DES VARIABLES EN FONCTION DES OBJETS EXTERNES
  369. *      write(6,*) ' proced appel inipro'
  370.       CALL INIPRO(cnompr,mblo1)
  371. *      write(6,*) ' proced sortie inipro'
  372.       SEGDES MTXBI3
  373.  
  374. C RECOPIE DES ARGUMENTS DANS LA PILE
  375.       IARGUM=MARGUM
  376.       SEGACT IARGUM
  377.       IF(NARG.NE.0) THEN
  378.         DO 2 I =1,NARG
  379.         II=2*I-1
  380.         I5=I-1+MDEOBJ
  381.         INOOB2(I5)=MTYYYA(I)
  382.         IOUEP2(I5)=IVAL(II+1)
  383.         IF(IVAL(II).EQ.0) THEN
  384.           INOOB2(I5)='ANNULE  '
  385.         ENDIF
  386.    2    CONTINUE
  387.         SEGSUP IVAL ,MTYYYB
  388.       ENDIF
  389.       SEGDES IARGUM
  390.       END
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401.  

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