1 : C PROCED SOURCE CHAT 11/05/04 21:17:51 6963 2 : SUBROUTINE PROCED 3 : IMPLICIT INTEGER(I-N) 4 : -INC CCOPTIO 5 : -INC SMBLOC 6 : -INC CCNOYAU 7 : -INC CCREDLE 8 : SEGMENT IVAL(2*NARG) 9 : SEGMENT MTYYYB 10 : CHARACTER*(8) MTYYYA(NARG) 11 : ENDSEGMENT 12 : SEGMENT ITITE3 13 : INTEGER ITITEN(NIS), IOU(NIS) 14 : CHARACTER*(8) ITITEM(NIS) 15 : ENDSEGMENT 16 : CHARACTER*8 MCOTA,cnompr 17 : CHARACTER*72 MTYTA 18 : REAL*8 XRE 19 : LOGICAL LOGI 20 : CHARACTER*4 MDEB(2),CRET,CHA1 21 : DATA MDEB/'DEBP','DEBM'/ 22 : sredle=iredle 23 : * write(6,*) ' entreee dans proced lmnnom ' , lmnnom 24 : * if(iimpi.eq.1876) write(6,*) ' proced avant appel dune proc' 24 : CALL LIROBJ('PROCEDUR',IARGO,1,IRETOU) 25 : IARGUM= IPIPR1(IARGO) 26 : * if(iimpi.eq.1754) then 26 : call quenom(cnompr) 27 : * write(6,*) ' nom de la procedure ' , cnompr 28 : * endif 29 : MBLO1=IARGUM 30 : IF(IERR.NE.0) RETURN 31 : IF(IIMPI.EQ.1754) WRITE(IOIMP,965) IARGUM 32 : 965 FORMAT(' DANS PROCED VALEUR DE IARGUM ',I8) 33 : * LA FIN DU IF EST MISE EN COOMENTAIRE 34 : IF(IARGUM.LT.0) THEN 34 : CALL PROCPO(-IARGUM,CRET) 34 : IF(CRET.NE.'9999') CALL ERREUR(5) 35 : IF (IERR.NE.0) RETURN 36 : IOLEC=-IOLEC 37 : IECHA=IECHO 38 : IECHO=max( 0,iecho - 1) 39 : C SAUVETAGE DU TYPE DES OBJETS TEMPORAIRE 40 : ITITE=0 41 : IF(IPTEM.NE.0) THEN 42 : ITITE=1 43 : MOT(1:8)='#' 44 : IRE=3 45 : NIS=IPTEM 46 : SEGINI ITITE3 47 : DO 112 I=1,IPTEM 48 : IF(I.LT.10)THEN 49 : WRITE(MOT(2:2),FMT='(I1)')I 50 : NCAR=2 51 : ELSE 52 : WRITE(MOT(2:3),FMT='(I2)')I 53 : NCAR=3 54 : ENDIF 55 : IAVA=0 55 : CALL PRENOM(IPLAMO,IAVA,sredle) 56 : ITITEN(I)=IPLAMO 57 : ITITEM(I)=INOOB2(IPLAMO) 58 : IOU(I)=IOUEP2(IPLAMO) 59 : 112 CONTINUE 60 : ENDIF 61 : C FIN DU SAUVETAGE 61 : CALL PROCSA 62 : MBFONC=1 63 : MSABL=MBLSUP 64 : MBLSUP=0 65 : IRZTC=0 66 : * If(iimpi.eq.1876) write(6,*) ' proced avant appel lirmot' 66 : CALL LIRMOT(MDEB,2,IRET,1) 67 : * If(iimpi.eq.1876)write(6,*)' proced apres lirmot iret',iret 68 : IF(IERR.NE.0) RETURN 69 : MBLSUP=MSABL 70 : CRET=LOCERR(1:4) 71 : LOCERR(1:4)=MDEB(IRET) 72 : * write(6,*) ' appel mapr lmnnom ', lmnnom 72 : CALL MAPR(IRET) 73 : * write(6,*) ' sorteri mapr lmnnom', lmnnom 74 : LOCERR(1:4)=CRET 75 : IF(IERR.NE.0) RETURN 76 : C 77 : C *** ON REMET LES TYPES DES OBJETS TEMPORAIRES 78 : C 79 : * write(6,*) ' iouep2(/1) ',iouep2(/1) 80 : IF(ITITE.NE.0) THEN 81 : DO 113 I=1,ITITEN(/1) 82 : IPLAMO=ITITEN(I) 83 : * write(6,*) ' iplamo ' , iplamo 84 : INOOB2(IPLAMO)=ITITEM(I) 85 : IOUEP2(IPLAMO)=IOU(I) 86 : 113 CONTINUE 87 : SEGSUP ITITE3 88 : ENDIF 89 : IECHO=IECHA 90 : IOLEC=ABS(IOLEC) 91 : MBLO1=IPIPR1(IARGO) 91 : CALL PROCRE 92 : ENDIF 93 : * FIN DU IF ICI ICI ICI ICI ICI 94 : C ON ACTIVE LE SEGMENT DONNANT LES ARGUMENTS , 95 : * write(6,*) ' lmnnom ' , lmnnom 96 : SEGACT MBLO1 97 : * write(6,*) ' mdeobj mfiobj lmnnom ' , mblo1.mdeobj, 98 : * $ mblo1.mfiobj,lmnnom 99 : IARGUM=MBLO1.MARGUM 100 : SEGACT IARGUM 101 : * write(6,*)'ent proced lmnnom mdeobj mfiobj',lmnnom,mdeobj,mfiobj 102 : C ON LIT LES ARGUMENTS ON SAUVE LEURS VALEURS DANS IVAL 103 : NARG= MTYARG(/2) 104 : IOPRME=MTXMET 105 : IF(IIMPI.EQ.1754) WRITE(6,4834) IARGUM,NARG 106 : 4834 FORMAT(' PROCED : IARGUM NARG',2I5) 107 : IF(IOPRME.EQ.2) THEN 108 : C on est en presence d'une methodeil faut lire lobjet su lequel elle 109 : C s'applique 109 : CALL LIROBJ('OBJET ', IRETCO,1,IRETOU) 110 : IF(IERR.NE.0) RETURN 111 : ENDIF 112 : IF(NARG.NE.0) THEN 113 : SEGINI IVAL ,MTYYYB 114 : DO 1 I =1,NARG 115 : II = 2 * I - 1 116 : MCOTA=MTYARG(I) 117 : MTYYYA(I)= MCOTA 118 : ICOND=IOBLIG(I) 119 : IF(MCOTA.EQ.'FLOTTANT') THEN 119 : CALL LIRREE(XRE,ICOND,IRETOU) 119 : CALL QUERAN(IRAT,MCOTA,IRET,XRE,CHA1,LOGI,IOB) 120 : ELSEIF(MCOTA.EQ.'TABLE ')THEN 121 : IFICHA=ILTYPA(I) 122 : IF(IFICHA.NE.0) THEN 123 : MTYTA= MSTYPA(I) 123 : CALL LIRTAB( MTYTA(1:IFICHA),IRAT,ICOND,IRETOU) 124 : ELSE 124 : CALL LIROBJ('TABLE ',IRAT,ICOND,IRETOU) 125 : ENDIF 126 : ELSE 126 : CALL LIRABJ(MCOTA,IRAT,ICOND,IRETOU) 127 : MTYYYA(I)= MCOTA 128 : ENDIF 129 : IF(IERR.NE.0) THEN 130 : SEGDES MBLO1,IARGUM 131 : RETURN 132 : ENDIF 133 : IF(IRETOU.EQ.0) THEN 134 : IVAL(II)=0 135 : ELSE 136 : IVAL(II)=1 137 : IVAL(II+1)=IRAT 138 : ENDIF 139 : IF(IIMPI.EQ.1754) THEN 140 : WRITE(IOIMP,FMT='('' ARGUMENT TYPE EXIS POINTEUR'',A8,2I6)') 141 : $ MTYARG(I),IVAL(II) 142 : ENDIF 143 : 1 CONTINUE 144 : ENDIF 145 : MTXBI3=MTXBB 146 : MTXFL3 = MTXFLO 147 : C ON ECRIT LES ARGUMENTS DANS LA PILE DES OBJETS 148 : C AUPREALABLE SAUVETAGE LECTURE ET ACTIVATION DU BLOC 148 : CALL PROCSA 149 : MTEM=MBLOC 150 : MTXBLC=MTXBL 151 : IF(MTXBL.NE.0) SEGDES MTXBLC 152 : ISSPOT=ISPOTE 153 : SEGDES ISSPOT 154 : SEGDES MBLOC 155 : SEGINI,MBLOC=MBLO1 156 : lmnlon=mfiobj-mdeobj 157 : mdeobj=lmnnom+1 158 : mfiobj=mdeobj+lmnlon 159 : * write(6,*)'sor proced lmnlon mdeobj mfiobj',lmnnom,mdeobj,mfiobj 160 : lmnnom=mfiobj 161 : n=iouep2(/1) 162 : if( n.lt.lmnnom) then 163 : n=lmnnom+100 164 : segadj,itabob,itaboc,itabod 165 : endif 166 : ISSPOT=ISPOTE 167 : SEGDES ISSPOT 168 : NVQTEM=20 169 : SEGINI ISSPOT 170 : ISPOTE=ISSPOT 171 : SEGDES MBLO1 172 : MBLSUP=MTEM 173 : MBLPRO=MBLO1 174 : MTXBLC=MTXBL 175 : 176 : IF(IOPRME.EQ.2) THEN 177 : MOBJCO=IRETCO 178 : ENDIF 179 : IF(MTXBL.NE.0) SEGACT MTXBLC 180 : MBFONC=0 181 : MBCOUR=0 182 : IPSI=0 183 : MBERR=0 184 : MBCONT=1 185 : C 186 : C **** ON MET DE COTE LA VALEUR DE LA PILE AFFECTEE A LA PROCEDURE 187 : C EN VUE DU RECURSIF 188 : NBMOT= MFIOBJ-MDEOBJ+1 189 : * SEGINI MSAPI3 190 : * MSAPII=MSAPI3 191 : * DO 252 J=1,NBMOT 192 : * MSAPIJ(J)=INOOB1(MDEOBJ-1+J) 193 : * MSAPIL(J)=INOOB2(MDEOBJ-1+J) 194 : * MSAPIN(J)=IOUEP2(MDEOBJ-1+J) 195 : * 252 CONTINUE 196 : * SEGDES MSAPI3 197 : C REMISE DES NOMS DES OBJETS DE LA PROCEDURE ET DE LEUR TYPES 198 : SEGACT MTXBI3 199 : J=0 200 : JLO=MTXBI(/1) 201 : * write(6,*) ' proced remise en etat de inoob1 mdeobj' , mdeobj 202 : DO 154 I=MDEOBJ,MFIOBJ 203 : J= J + 1 204 : INOOB1(I)=MTXBI(J) 205 : inoob2(i)=mtxbd(j) 206 : IOUEP2(i)=mtxbe(j) 207 : * write(6,*) ' i, inoob ' , i , inoob1(i),inoob2(i),iouep2(i) 208 : 154 CONTINUE 209 : C REMISE DES VALEURS DES FLOTTANTS 210 : IF( MTXFLO.NE.0) THEN 211 : SEGACT MTXFL3 212 : NREE = MITFLO(/1) 213 : IF ( NREE . NE . 0) THEN 213 : CALL POSCHA('##BID##',IPOSCH) 214 : DO 155 I=1,NREE 215 : NOMBID=INOOB1(MITFLO(I)+mdeobj-1) 216 : INOOB1(MITFLO(I)+mdeobj-1)=IPOSCH 217 : XRE = XTFLO(I) 217 : CALL NOMREE ('##BID##',XRE) 218 : INOOB1(MITFLO(I)+mdeobj-1)=NOMBID 219 : 155 CONTINUE 220 : ENDIF 221 : SEGDES MTXFL3 222 : ENDIF 223 : C INITIALISATION DES VARIABLES EN FONCTION DES OBJETS EXTERNES 224 : * write(6,*) ' proced appel inipro' 224 : CALL INIPRO(cnompr,mblo1) 225 : * write(6,*) ' proced sortie inipro' 226 : SEGDES MTXBI3 227 : C RECOPIE DES ARGUMENTS DANS LA PILE 228 : IARGUM=MARGUM 229 : SEGACT IARGUM 230 : IF(NARG.NE.0) THEN 231 : DO 2 I =1,NARG 232 : II=2*I-1 233 : I5=I-1+MDEOBJ 234 : INOOB2(I5)=MTYYYA(I) 235 : IOUEP2(I5)=IVAL(II+1) 236 : IF(IVAL(II).EQ.0) THEN 237 : INOOB2(I5)='ANNULE ' 238 : ENDIF 239 : 2 CONTINUE 240 : SEGSUP IVAL ,MTYYYB 241 : ENDIF 242 : SEGDES IARGUM 243 : RETURN 244 : END 245 : 246 : 247 :
© Cast3M 2003 - All rights reserved.
Disclaimer