C PROCED SOURCE CHAT 11/05/04 21:17:51 6963 SUBROUTINE PROCED IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC SMBLOC -INC CCNOYAU -INC CCREDLE SEGMENT IVAL(2*NARG) SEGMENT MTYYYB CHARACTER*(8) MTYYYA(NARG) ENDSEGMENT SEGMENT ITITE3 INTEGER ITITEN(NIS), IOU(NIS) CHARACTER*(8) ITITEM(NIS) ENDSEGMENT CHARACTER*8 MCOTA,cnompr CHARACTER*72 MTYTA REAL*8 XRE LOGICAL LOGI CHARACTER*4 MDEB(2),CRET,CHA1 DATA MDEB/'DEBP','DEBM'/ sredle=iredle * write(6,*) ' entreee dans proced lmnnom ' , lmnnom * if(iimpi.eq.1876) write(6,*) ' proced avant appel dune proc' CALL LIROBJ('PROCEDUR',IARGO,1,IRETOU) IARGUM= IPIPR1(IARGO) * if(iimpi.eq.1754) then call quenom(cnompr) * write(6,*) ' nom de la procedure ' , cnompr * endif MBLO1=IARGUM IF(IERR.NE.0) RETURN IF(IIMPI.EQ.1754) WRITE(IOIMP,965) IARGUM 965 FORMAT(' DANS PROCED VALEUR DE IARGUM ',I8) * LA FIN DU IF EST MISE EN COOMENTAIRE IF(IARGUM.LT.0) THEN CALL PROCPO(-IARGUM,CRET) IF(CRET.NE.'9999') CALL ERREUR(5) IF (IERR.NE.0) RETURN IOLEC=-IOLEC IECHA=IECHO IECHO=max( 0,iecho - 1) C SAUVETAGE DU TYPE DES OBJETS TEMPORAIRE ITITE=0 IF(IPTEM.NE.0) THEN ITITE=1 MOT(1:8)='#' IRE=3 NIS=IPTEM SEGINI ITITE3 DO 112 I=1,IPTEM IF(I.LT.10)THEN WRITE(MOT(2:2),FMT='(I1)')I NCAR=2 ELSE WRITE(MOT(2:3),FMT='(I2)')I NCAR=3 ENDIF IAVA=0 CALL PRENOM(IPLAMO,IAVA,sredle) ITITEN(I)=IPLAMO ITITEM(I)=INOOB2(IPLAMO) IOU(I)=IOUEP2(IPLAMO) 112 CONTINUE ENDIF C FIN DU SAUVETAGE CALL PROCSA MBFONC=1 MSABL=MBLSUP MBLSUP=0 IRZTC=0 * If(iimpi.eq.1876) write(6,*) ' proced avant appel lirmot' CALL LIRMOT(MDEB,2,IRET,1) * If(iimpi.eq.1876)write(6,*)' proced apres lirmot iret',iret IF(IERR.NE.0) RETURN MBLSUP=MSABL CRET=LOCERR(1:4) LOCERR(1:4)=MDEB(IRET) * write(6,*) ' appel mapr lmnnom ', lmnnom CALL MAPR(IRET) * write(6,*) ' sorteri mapr lmnnom', lmnnom LOCERR(1:4)=CRET IF(IERR.NE.0) RETURN C C *** ON REMET LES TYPES DES OBJETS TEMPORAIRES C * write(6,*) ' iouep2(/1) ',iouep2(/1) IF(ITITE.NE.0) THEN DO 113 I=1,ITITEN(/1) IPLAMO=ITITEN(I) * write(6,*) ' iplamo ' , iplamo INOOB2(IPLAMO)=ITITEM(I) IOUEP2(IPLAMO)=IOU(I) 113 CONTINUE SEGSUP ITITE3 ENDIF IECHO=IECHA IOLEC=ABS(IOLEC) MBLO1=IPIPR1(IARGO) CALL PROCRE ENDIF * FIN DU IF ICI ICI ICI ICI ICI C ON ACTIVE LE SEGMENT DONNANT LES ARGUMENTS , * write(6,*) ' lmnnom ' , lmnnom SEGACT MBLO1 * write(6,*) ' mdeobj mfiobj lmnnom ' , mblo1.mdeobj, * $ mblo1.mfiobj,lmnnom IARGUM=MBLO1.MARGUM SEGACT IARGUM * write(6,*)'ent proced lmnnom mdeobj mfiobj',lmnnom,mdeobj,mfiobj C ON LIT LES ARGUMENTS ON SAUVE LEURS VALEURS DANS IVAL NARG= MTYARG(/2) IOPRME=MTXMET IF(IIMPI.EQ.1754) WRITE(6,4834) IARGUM,NARG 4834 FORMAT(' PROCED : IARGUM NARG',2I5) IF(IOPRME.EQ.2) THEN C on est en presence d'une methodeil faut lire lobjet su lequel elle C s'applique CALL LIROBJ('OBJET ', IRETCO,1,IRETOU) IF(IERR.NE.0) RETURN ENDIF IF(NARG.NE.0) THEN SEGINI IVAL ,MTYYYB DO 1 I =1,NARG II = 2 * I - 1 MCOTA=MTYARG(I) MTYYYA(I)= MCOTA ICOND=IOBLIG(I) IF(MCOTA.EQ.'FLOTTANT') THEN CALL LIRREE(XRE,ICOND,IRETOU) CALL QUERAN(IRAT,MCOTA,IRET,XRE,CHA1,LOGI,IOB) ELSEIF(MCOTA.EQ.'TABLE ')THEN IFICHA=ILTYPA(I) IF(IFICHA.NE.0) THEN MTYTA= MSTYPA(I) CALL LIRTAB( MTYTA(1:IFICHA),IRAT,ICOND,IRETOU) ELSE CALL LIROBJ('TABLE ',IRAT,ICOND,IRETOU) ENDIF ELSE CALL LIRABJ(MCOTA,IRAT,ICOND,IRETOU) MTYYYA(I)= MCOTA ENDIF IF(IERR.NE.0) THEN SEGDES MBLO1,IARGUM RETURN ENDIF IF(IRETOU.EQ.0) THEN IVAL(II)=0 ELSE IVAL(II)=1 IVAL(II+1)=IRAT ENDIF IF(IIMPI.EQ.1754) THEN WRITE(IOIMP,FMT='('' ARGUMENT TYPE EXIS POINTEUR'',A8,2I6)') $ MTYARG(I),IVAL(II) ENDIF 1 CONTINUE ENDIF MTXBI3=MTXBB MTXFL3 = MTXFLO C ON ECRIT LES ARGUMENTS DANS LA PILE DES OBJETS C AUPREALABLE SAUVETAGE LECTURE ET ACTIVATION DU BLOC CALL PROCSA MTEM=MBLOC MTXBLC=MTXBL IF(MTXBL.NE.0) SEGDES MTXBLC ISSPOT=ISPOTE SEGDES ISSPOT SEGDES MBLOC SEGINI,MBLOC=MBLO1 lmnlon=mfiobj-mdeobj mdeobj=lmnnom+1 mfiobj=mdeobj+lmnlon * write(6,*)'sor proced lmnlon mdeobj mfiobj',lmnnom,mdeobj,mfiobj lmnnom=mfiobj n=iouep2(/1) if( n.lt.lmnnom) then n=lmnnom+100 segadj,itabob,itaboc,itabod endif ISSPOT=ISPOTE SEGDES ISSPOT NVQTEM=20 SEGINI ISSPOT ISPOTE=ISSPOT SEGDES MBLO1 MBLSUP=MTEM MBLPRO=MBLO1 MTXBLC=MTXBL IF(IOPRME.EQ.2) THEN MOBJCO=IRETCO ENDIF IF(MTXBL.NE.0) SEGACT MTXBLC MBFONC=0 MBCOUR=0 IPSI=0 MBERR=0 MBCONT=1 C C **** ON MET DE COTE LA VALEUR DE LA PILE AFFECTEE A LA PROCEDURE C EN VUE DU RECURSIF NBMOT= MFIOBJ-MDEOBJ+1 * SEGINI MSAPI3 * MSAPII=MSAPI3 * DO 252 J=1,NBMOT * MSAPIJ(J)=INOOB1(MDEOBJ-1+J) * MSAPIL(J)=INOOB2(MDEOBJ-1+J) * MSAPIN(J)=IOUEP2(MDEOBJ-1+J) * 252 CONTINUE * SEGDES MSAPI3 C REMISE DES NOMS DES OBJETS DE LA PROCEDURE ET DE LEUR TYPES SEGACT MTXBI3 J=0 JLO=MTXBI(/1) * write(6,*) ' proced remise en etat de inoob1 mdeobj' , mdeobj DO 154 I=MDEOBJ,MFIOBJ J= J + 1 INOOB1(I)=MTXBI(J) inoob2(i)=mtxbd(j) IOUEP2(i)=mtxbe(j) * write(6,*) ' i, inoob ' , i , inoob1(i),inoob2(i),iouep2(i) 154 CONTINUE C REMISE DES VALEURS DES FLOTTANTS IF( MTXFLO.NE.0) THEN SEGACT MTXFL3 NREE = MITFLO(/1) IF ( NREE . NE . 0) THEN CALL POSCHA('##BID##',IPOSCH) DO 155 I=1,NREE NOMBID=INOOB1(MITFLO(I)+mdeobj-1) INOOB1(MITFLO(I)+mdeobj-1)=IPOSCH XRE = XTFLO(I) CALL NOMREE ('##BID##',XRE) INOOB1(MITFLO(I)+mdeobj-1)=NOMBID 155 CONTINUE ENDIF SEGDES MTXFL3 ENDIF C INITIALISATION DES VARIABLES EN FONCTION DES OBJETS EXTERNES * write(6,*) ' proced appel inipro' CALL INIPRO(cnompr,mblo1) * write(6,*) ' proced sortie inipro' SEGDES MTXBI3 C RECOPIE DES ARGUMENTS DANS LA PILE IARGUM=MARGUM SEGACT IARGUM IF(NARG.NE.0) THEN DO 2 I =1,NARG II=2*I-1 I5=I-1+MDEOBJ INOOB2(I5)=MTYYYA(I) IOUEP2(I5)=IVAL(II+1) IF(IVAL(II).EQ.0) THEN INOOB2(I5)='ANNULE ' ENDIF 2 CONTINUE SEGSUP IVAL ,MTYYYB ENDIF SEGDES IARGUM RETURN END