1 : C FINPRO SOURCE JC220346 13/12/17 21:15:05 7885 2 : SUBROUTINE FINPRO 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : -INC CCOPTIO 6 : -INC SMBLOC 7 : -INC CCNOYAU 8 : -INC CCASSIS 9 : -INC SMTABLE 10 : CHARACTER*(8) MMM,NOM1,NOMPRC 11 : CHARACTER*(72) PPP 12 : LOGICAL BBV 13 : IARGUM=MARGUM 14 : IF(IARGUM.EQ.0) THEN 14 : CALL ERREUR (154) 15 : RETURN 16 : ENDIF 16 : call ooohor(0,0) 17 : IRETOB=MOBJCO 17 : CALL RESPRO 18 : SEGACT IARGUM*MOD 19 : * MSAPI3=MSAPII 20 : * SEGACT MSAPI3 21 : * DO 5 J=1,MSAPIJ(/1) 22 : * INOOB1(MDEOBJ-1+J)=MSAPIJ(J) 23 : ** INOOB2(MDEOBJ-1+J)=MSAPIL(J) 24 : * IF(MSAPIL(J).NE.'FLOTTANT'.OR.MSAPIJ(J).NE.1) 25 : * $ IOUEP2(MDEOBJ-1+J)=MSAPIN(J) 26 : * 5 CONTINUE 27 : * SEGSUP MSAPI3 28 : C 29 : C CHANGEMENT DE BLOC, RETOUR AU PRECEDENTE 30 : C 31 : MTEM=MBLSUP 32 : MTXBLC=MTXBL 33 : IF(MTXBL.NE.0) SEGDES MTXBLC 34 : MBIR=MBERR 35 : ISSPOT=ISPOTE 36 : SEGSUP ISSPOT 37 : lmnanc=lmnnom 38 : lmnnom=mdeobj-1 39 : 40 : * OPTI 'PROC' 'SAUV' (partie 1) 41 : * ================== 42 : IF (ZLOPRO) THEN 43 : 44 : IF(NBESC.NE.0) SEGACT IPILOC 45 : 46 : * on cherche le nom de la procedure courante dans la pile globale 47 : * (partie anterieure a la procedure) 48 : NOMPRC = ' ' 49 : DO 10 I=1,LMNNOM 50 : IF (INOOB1(I).EQ.1) GOTO 10 51 : IF (INOOB2(I).NE.'PROCEDUR') GOTO 10 52 : IF (IPIPR1(IOUEP2(I)).NE.MBLPRO) GOTO 10 53 : IP=INOOB1(I) 54 : IDEBCH=IPCHAR(IP) 55 : IFINCH=IPCHAR(IP+1)-1 56 : NOMPRC=ICHARA(IDEBCH:IFINCH) 57 : GOTO 11 58 : 10 CONTINUE 58 : CALL ERREUR(5) 59 : RETURN 60 : 11 CONTINUE 61 : 62 : * on sauvegarde dans une table les objets de la partie de la pile 63 : * globale qui est dediee a la procedure courante 64 : M = LMNANC - LMNNOM 65 : SEGINI MTAB1 66 : MTAB1.MLOTAB=M 67 : NOBJ=0 68 : DO 20 I=LMNNOM+1,LMNANC 69 : IP=INOOB1(I) 70 : IDEBCH=IPCHAR(IP) 71 : IFINCH=IPCHAR(IP+1)-1 72 : NOM1=ICHARA(IDEBCH:IFINCH) 73 : * on va quand meme eliminer certains des objets dont le nom, 74 : * le type et/ou la valeur ne nous plaisent pas... 75 : IF (NOM1.EQ.' ') GOTO 21 76 : IF (NOM1(1:1).EQ.'#') GOTO 21 77 : IF (NOM1.EQ.'FINP') GOTO 21 78 : IF (INOOB2(I).EQ.'PROCEDUR') GOTO 21 79 : GOTO 22 80 : 21 CONTINUE 81 : INOOB1(I)=0 82 : INOOB2(I)=' ' 83 : IOUEP2(I)=0 84 : GOTO 20 85 : 22 CONTINUE 86 : NOBJ=NOBJ+1 87 : MTAB1.MTABTI(NOBJ) = 'MOT ' 88 : MTAB1.MTABII(NOBJ) = INOOB1(I) 89 : MTAB1.MTABTV(NOBJ) = INOOB2(I) 90 : IF (INOOB2(I).EQ.'FLOTTANT') THEN 91 : IF (NBESC.NE.0) SEGACT,IPILOC 92 : MTAB1.RMTABV(NOBJ)=XIFLOT(IOUEP2(I)) 93 : IF (NBESC.NE.0) SEGDES,IPILOC 94 : ELSE 95 : MTAB1.MTABIV(NOBJ)=IOUEP2(I) 96 : ENDIF 97 : 20 CONTINUE 98 : M=NOBJ 99 : MTAB1.MLOTAB = M 100 : SEGADJ,MTAB1 101 : 102 : 103 : * OPTI 'PROC' 'OUBL' 104 : * ================== 105 : ELSE 106 : 107 : * on efface la partie de la pile qui etait affectée à la procedure 108 : DO IAZ=LMNNOM+1,LMNANC 109 : INOOB1(IAZ)=0 110 : INOOB2(IAZ)=' ' 111 : IOUEP2(IAZ)=0 112 : ENDDO 113 : 114 : ENDIF 115 : 116 : 117 : * ON RECHARGE LE BLOC PARENT 118 : * write(6,*) ' finpro lmnnom' , lmnnom 119 : SEGSUP MBLOC 120 : MBLOC=MTEM 121 : SEGACT MBLOC*MOD 122 : ISSPOT=ISPOTE 123 : SEGACT ISSPOT*MOD 124 : MBERR=MBIR 125 : MTXBLC=MTXBL 126 : IF(MTXBL.NE.0) SEGACT MTXBLC 126 : CALL PROCRE 127 : 128 : 129 : * OPTI 'PROC' 'SAUV' (partie 2) 130 : * ================== 131 : IF (ZLOPRO) THEN 132 : NOM1(1:1)='&' 133 : NOM1(2:8)=NOMPRC(1:7) 134 : IF(NBESC.NE.0) SEGDES IPILOC 134 : CALL NOMOBJ('TABLE ',NOM1,MTAB1) 135 : ENDIF 136 : 137 : C 138 : C ECRITURE DES RESULTAS DANS LA PILE DES OBJETS LUS 139 : C 140 : MTRESU=ITRESU 141 : MVRESU=IVRESU 142 : MFRESU=IFRESU 143 : IF(MTRESU.NE.0) THEN 144 : SEGACT MTRESU,MVRESU,MFRESU 145 : NRES = IVARES(/1) 146 : IF(IIMPI.EQ.1754) WRITE(IOIMP,*)' DANS FINPRO NRES ',NRES 147 : IF(NRES.NE.0.AND.MBIR.EQ.0) THEN 148 : DO 2 ILERT=1,NRES 149 : if(nbesc.ne.0) segact ipiloc 150 : I = NRES - ILERT + 1 151 : MMM=MTYRES(I) 152 : IIP=IVARES(I) 153 : IF(MMM.EQ.'ENTIER ') THEN 154 : IIV=IIP 154 : CALL ECRENT(IIV) 155 : ELSEIF(MMM.EQ.'FLOTTANT')THEN 156 : XXA=XFLRES(I) 156 : CALL ECRREE(XXA) 157 : ELSEIF(MMM.EQ.'MOT ') THEN 158 : IIC=IPCHAR(IIP) 159 : IID=IPCHAR(IIP+1) 160 : PPP=' ' 161 : PPP(1:IID-IIC)=ICHARA(IIC:IID-1) 161 : CALL ECRCHA(PPP(1:IID-IIC)) 162 : ELSEIF(MMM.EQ.'LOGIQUE ') THEN 163 : BBV=IPLOGI(IIP) 163 : CALL ECRLOG(BBV) 164 : ELSEIF(MMM.EQ.'METHODOL') THEN 165 : * write(6,*) ' finpro iretob',iretob 165 : CALL ECROBJ('OBJET ',IRETOB) 166 : ELSE 166 : CALL ECROBJ(MMM,IIP) 167 : ENDIF 168 : 2 CONTINUE 169 : if(nbesc.ne.0) segdes ipiloc 170 : ENDIF 171 : SEGSUP MTRESU,MVRESU,MFRESU 172 : ENDIF 173 : ITRESU=0 174 : IVRESU=0 175 : IFRESU=0 176 : SEGDES IARGUM 177 : LECTAB=1 178 : INTEXT=1 179 : * write(6,*)'sortie de finpro lmnnom mbloc ' ,lmnnom, mbloc 180 : * write(6,*)'nbnom mbcour ipvir intemp',nbnom,mbcour,ipvir,intemp 181 : RETURN 182 : END 183 : 184 : 185 : 186 :
© Cast3M 2003 - All rights reserved.
Disclaimer