1 : C OPERDI SOURCE GOUNAND 12/07/25 21:15:00 7443 2 : SUBROUTINE OPERDI 3 : *_______________________________________________________________________ 4 : * 5 : * DIVISE UN LISTREEL PAR UN FLOTTANT (OU UN ENTIER) 6 : * DIVISE UN CHAMPS PAR ELEMT PAR UN FLOTTANT (OU 1 ENTIER) 7 : * DIVISE UN OBJET RIGIDITE PAR UN FLOTTANT (OU UN ENTIER) 8 : * DIVISE UN CHAMP PAR POINT PAR UN AUTRE CHAMP PAR POINT 9 : * DIVISE UN CHAMPS PAR POINT PAR UN FLOTTANT (OU 1 ENTIER) 10 : * DIVISE 2 NOMBRES (FLOTTANT OU ENTIER) 11 : * DIVISE UN POINT PAR UN NOMBRE 12 : * DIVISE UN OBJET EVOLUTIO (ORDONNEES) PAR UN FLOTTANT 13 : * (OU UN ENTIER) 14 : * DIVISE UN OBJET EVOLUTIO PAR UN OBJET EVOLUTIO 15 : * DIVISE UNE TABLE SOUSTYPE VECTEUR PAR UN REEL 16 : * 17 : * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 12/90 18 : * 19 : *_______________________________________________________________________ 20 : * 21 : IMPLICIT INTEGER(I-N) 22 : IMPLICIT REAL*8(A-H,O-Z) 23 : * 24 : -INC CCREEL 25 : -INC CCOPTIO 26 : -INC SMCOORD 27 : -INC SMTABLE 28 : -INC SMLREEL 29 : -INC SMLCHPO 30 : * 31 : * CHERCHE A LIROBJ DEUX CHAMPS PAR ELEMENT (MCHAML) 32 : * 32 : 100 CALL LIROBJ('MCHAML',IPCHE1,0,IRETOU) 33 : IF(IRETOU.EQ.0) GOTO 101 33 : CALL LIROBJ('MCHAML',IPCHE2,0,IRETOU) 34 : IF(IRETOU.EQ.0) THEN 34 : CALL REFUS 35 : GO TO 101 36 : ENDIF 37 : IPLREE = 0 38 : IPLMOT = 0 38 : CALL MUCHSC(0,IPCHE1,IPCHE2,IPCHMU,IPLMOT,IPLMOT,IPLMOT,IPLREE,-1) 39 : IF (IPCHMU.EQ.0) RETURN 39 : CALL ECROBJ('MCHAML',IPCHMU) 40 : RETURN 41 : * 42 : * CHERCHE A LIROBJ UN CHAMP PAR ELEMENT (MCHAML) ET UN FLOTTANT 43 : * 43 : 101 CALL LIROBJ('MCHAML',IPCHE1,0,IRETOU) 44 : IF(IRETOU.EQ.0) GOTO 102 44 : CALL LIRREE(FLO,0,IRETOU) 45 : IF(IRETOU.EQ.0) THEN 45 : CALL REFUS 46 : GO TO 102 47 : ENDIF 48 : IF(FLO.EQ.0.D0) GO TO 5000 49 : FLD=FLO 49 : CALL MUCHEL(IPCHE1,FLD,IPCHMU,-1) 50 : IF (IPCHMU.EQ.0) RETURN 50 : CALL ECROBJ('MCHAML',IPCHMU) 51 : RETURN 52 : * 53 : * CHERCHE A LIRE DEUX CHAMPS PAR POINT 54 : * 54 : 102 CALL LIROBJ('CHPOINT ',ICHP1,0,IRETOU) 55 : IF(IRETOU.EQ.0) GOTO 103 55 : CALL LIROBJ('CHPOINT ',ICHP2,0,IRETOU) 56 : IF(IRETOU.EQ.0) THEN 56 : CALL REFUS 57 : GO TO 103 58 : ENDIF 58 : CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU) 59 : IF ( IRETOU .EQ. 1) THEN 59 : CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU) 60 : IF (IERR .NE. 0) RETURN 60 : CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU) 61 : IF (IERR .NE. 0) RETURN 61 : CALL MUCHP1(ICHP1,ICHP2,LMOT1,LMOT2,LMOT3,-1,IRET) 61 : IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET) 62 : ELSE 62 : CALL MUPOSC(ICHP1,ICHP2,-1,IRET) 62 : IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET) 63 : ENDIF 64 : RETURN 65 : * 66 : * CHPOINT / FLOTTANT 67 : * 67 : 103 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU) 68 : IF(IRETOU.EQ.0) GOTO 104 68 : CALL LIRREE(FLO,0,IRETOU) 69 : IF(IRETOU.EQ.0) THEN 69 : CALL REFUS 70 : GO TO 104 71 : ENDIF 72 : IF(FLO.EQ.0.D0) GO TO 5000 73 : FLD=FLO 73 : CALL MUCHPO(IPO1,FLD,IRET,-1) 74 : IF(IRET.EQ.0) RETURN 74 : CALL ECROBJ('CHPOINT ',IRET) 75 : RETURN 76 : * 77 : * CHERCHE A LIROBJ UN OBJET DE TYPE RIGIDITE ET UN FLOTTANT 78 : * 78 : 104 CALL LIROBJ('RIGIDITE',IPO1,0,IRETOU) 79 : IF (IRETOU.EQ.0) GOTO 1041 79 : CALL LIRREE(FLO,0,IRETOU) 80 : IF (IRETOU.EQ.0) THEN 80 : CALL REFUS 81 : GO TO 1041 82 : ENDIF 83 : IF (FLO.EQ.0.D0) GOTO 5000 83 : CALL MUFLRI(IPO1,FLO,IRET,-1) 83 : CALL ECROBJ('RIGIDITE',IRET) 84 : RETURN 85 : * 86 : * CHERCHE A LIROBJ UN OBJET DE TYPE MATRIK ET UN FLOTTANT 87 : * 87 : 1041 CALL LIROBJ('MATRIK ',IPO1,0,IRETOU) 88 : IF (IRETOU.EQ.0) GOTO 105 88 : CALL LIRREE(FLO,0,IRETOU) 89 : IF (IRETOU.EQ.0) THEN 89 : CALL REFUS 90 : GO TO 105 91 : ENDIF 92 : IF (ABS(FLO).LT.XPETIT) GOTO 5000 92 : CALL PRDMF(1.D0/FLO,IPO1,IRET) 92 : IF (IRET.NE.0) CALL ECROBJ('MATRIK ',IRET) 93 : RETURN 94 : * 95 : * CHERCHE A LIROBJ UN OBJET DE TYPE EVOLUTIO ET UN FLOTTANT 96 : * 96 : 105 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU) 97 : IF (IRETOU.EQ.0) GOTO 106 97 : CALL LIRREE(FLO,0,IRETOU) 98 : IF (IRETOU.EQ.0) THEN 98 : CALL REFUS 99 : GO TO 106 100 : ENDIF 101 : IF (FLO.EQ.0.D0) GOTO 5000 101 : CALL MUFLEV(IPO1,FLO,IRET,-1) 101 : CALL ECROBJ('EVOLUTIO',IRET) 102 : RETURN 103 : * 104 : * EVOLUTIO / EVOLUTIO 105 : * 105 : 106 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU) 106 : IF (IRETOU.EQ.0) GOTO 107 106 : CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU) 107 : IF (IRETOU.EQ.0) THEN 107 : CALL REFUS 108 : GO TO 107 109 : ENDIF 109 : CALL PUIS(IPO1,IPO2,IRET,-1) 109 : CALL ECROBJ('EVOLUTIO',IRET) 110 : RETURN 111 : * 112 : * CHERCHE A LIROBJ UN LISTREEL ET UN LISTREEL 113 : * 113 : 107 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU) 114 : IF(IRETOU.EQ.0) GOTO 108 114 : CALL LIROBJ('LISTREEL',MLREE2,0,IRETOU) 115 : IF (IRETOU.EQ.0) THEN 115 : CALL REFUS 116 : GO TO 108 117 : ENDIF 118 : MLREE1 = IPO1 119 : SEGACT MLREE1,MLREE2 120 : JG=MLREE2.PROG(/1) 121 : IF(MLREE1.PROG(/1).NE.JG) THEN 121 : CALL ERREUR (21) 122 : RETURN 123 : ENDIF 124 : SEGINI MLREEL 125 : DO 150 I=1,JG 126 : X2 = MLREE2.PROG(I) 127 : *Gounand: on ne voit pas pourquoi on ferait un traitement 128 : * différent pour les LISTREEL 129 : * IF(ABS(X2).LT.1.D-30) X2=1.D-30 130 : IF(X2.EQ.0.D0) GOTO 5000 131 : PROG(I)=MLREE1.PROG(I)/X2 132 : 150 CONTINUE 133 : SEGDES MLREEL,MLREE1,MLREE2 133 : CALL ECROBJ('LISTREEL',MLREEL) 134 : RETURN 135 : * 136 : * LISTREEL / FLOTTANT OU ENTIER 137 : * 137 : 108 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU) 138 : IF(IRETOU.EQ.0) GOTO 109 138 : CALL LIRREE(FLO,0,IRETOU) 139 : IF(IRETOU.EQ.0) THEN 139 : CALL REFUS 140 : GO TO 109 141 : ENDIF 142 : IF(FLO.EQ.0.D0) GO TO 5000 142 : CALL MUFLIR(IPO1,FLO,IRET,-1) 143 : IF(IRET.EQ.0) RETURN 143 : CALL ECROBJ('LISTREEL',IRET) 144 : RETURN 145 : * 146 : * CHERCHE A LIROBJ 2 ENTIERS 147 : * 147 : 109 CALL LIRENT(I1,0,IRETOU) 148 : IF (IRETOU.EQ.0) GOTO 110 148 : CALL LIRENT(I2,0,IRETOU) 149 : IF (IRETOU.EQ.0) THEN 149 : CALL REFUS 150 : GO TO 110 151 : ENDIF 152 : IF (I2.EQ.0) GOTO 5000 152 : CALL ECRENT(I1/I2) 153 : RETURN 154 : C 155 : C CHERCHE A LIRE DEUX FLOTTANTS 156 : 156 : 110 CALL LIRREE(X1,0,IRETOU) 157 : IF ( IRETOU.EQ.0) GO TO 111 157 : CALL LIRREE(X2,0,IRETOU) 158 : IF (IRETOU.EQ.0) THEN 158 : CALL REFUS 159 : GO TO 111 160 : ENDIF 161 : IF(X2.EQ.0.D0) GOTO 5000 161 : CALL ECRREE(X1/X2) 162 : RETURN 163 : * 164 : * CHERCHE A LIROBJ UN POINT ET UN FLOTTANT 165 : * 165 : 111 CALL LIROBJ('POINT ',IP1,0,IRETOU) 166 : IF (IRETOU.EQ.0) GOTO 112 166 : CALL LIRREE(X2,0,IRETOU) 167 : IF (IRETOU.EQ.0) THEN 167 : CALL REFUS 168 : GO TO 112 169 : ENDIF 170 : IF(X2.EQ.0.D0) GOTO 5000 171 : SEGACT MCOORD*MOD 172 : ID=IDIM+1 173 : IREF=ID*(IP1-1) 174 : DO 11 I=1,ID 175 : XCOOR(**)=XCOOR(IREF+I)/X2 176 : 11 CONTINUE 177 : IR=XCOOR(/1)/ID 177 : CALL ECROBJ('POINT ',IR) 178 : RETURN 179 : * 180 : * CHERCHE A LIRE UNE TABLE SOUSTYPE VECTEUR ET UN FLOTTANT 181 : * 181 : 112 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU) 182 : IF(IRETOU.EQ.0) GO TO 113 182 : CALL LIRREE(X2,0,IRETOU) 183 : IF (IRETOU.EQ.0) THEN 183 : CALL REFUS 184 : GO TO 113 185 : ENDIF 186 : IF(X2.EQ.0.D0) GOTO 5000 187 : SEGINI,MTABLE=MTAB1 188 : DO 701 I=1,MLOTAB 189 : IF (MTABTV(I).EQ.'FLOTTANT') THEN 190 : RMTABV(I)=RMTABV(I)/X2 191 : ELSEIF (MTABTV(I).EQ.'ENTIER ') THEN 192 : RMTABV(I)=MTABIV(I)/X2 193 : MTABTV(I)='FLOTTANT' 194 : ENDIF 195 : 701 CONTINUE 196 : SEGDES MTABLE,MTAB1 196 : CALL ECROBJ('TABLE',MTABLE) 197 : RETURN 198 : C 198 : 113 CALL LIROBJ('LISTCHPO',LIPO1,0,IRETOU) 199 : IF(IRETOU.EQ.0) GOTO 114 199 : CALL LIROBJ('LISTREEL',LREE1,0,IRETOU) 200 : IF(IRETOU.EQ.0) THEN 200 : CALL REFUS 201 : GO TO 114 202 : ENDIF 203 : mlreel = lree1 204 : mlchp1 = lipo1 205 : segact mlchp1,mlreel 206 : jg = prog(/1) 207 : n1 = mlchp1.ichpoi(/1) 207 : if (jg.ne.n1) call erreur(3) 208 : if (ierr.ne.0) return 209 : segini mlchpo 210 : do ic = 1,n1 211 : flo = prog(ic) 212 : ipo1 = mlchp1.ichpoi(ic) 213 : IF(FLO.EQ.0.D0) GO TO 5000 214 : FLD=FLO 214 : CALL MUCHPO(IPO1,FLD,IRET,-1) 215 : IF(IRET.EQ.0) RETURN 216 : ichpoi(ic) = iret 217 : enddo 218 : segdes mlchpo,mlchp1,mlreel 218 : CALL ECROBJ('LISTCHPO',mlchpo) 219 : RETURN 220 : C 221 : C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION 222 : C 223 : 114 CONTINUE 223 : CALL QUETYP(MOTERR(1:8),0,IRETOU) 224 : IF(IRETOU.NE.0) THEN 224 : CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU) 224 : CALL QUETYP(MOTERR(9:16),0,IRETOU) 225 : IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? ' 225 : CALL ERREUR(532) 226 : ELSE 226 : CALL ERREUR(533) 227 : ENDIF 228 : RETURN 229 : 5000 CONTINUE 229 : CALL ERREUR(835) 230 : RETURN 231 : END 232 : 233 : 234 : 235 : 236 :
© Cast3M 2003 - All rights reserved.
Disclaimer