1 : C FSUR SOURCE FANDEUR 12/07/18 21:15:43 7434 2 : * 3 : SUBROUTINE FSUR 4 : * 5 : *----------------------------------------------------------------------- 6 : * 7 : * OPERATEUR FSUR 8 : * 9 : *----------------------------------------------------------------------- 10 : * 11 : IMPLICIT INTEGER(I-N) 12 : IMPLICIT REAL*8 (A-H,O-Z) 13 : * 14 : -INC CCOPTIO 15 : * 16 : -INC SMCHPOI 17 : * 18 : PARAMETER (NTYPE = 3, NTYPR = 1) 19 : CHARACTER*4 MTYPE(NTYPE),MTYPR(NTYPR) 20 : * 21 : DATA MTYPE / 'MASS','COQU','POUT' / 22 : DATA MTYPR / 'PROJ' / 23 : * 24 : IMLU = 0 25 : IPMODL = 0 26 : IPCHPS = 0 27 : IPVECT = 0 28 : IPMAIL = 0 29 : IPCARA = 0 30 : IPCHPF = 0 31 : * 32 : *----------------------------------------------------------------------- 33 : * LECTURE DES ARGUMENTS 34 : *----------------------------------------------------------------------- 35 : * 36 : * ON LIT UN MOT-CLE OBLIGATOIRE 37 : * 37 : CALL LIRMOT(MTYPE,NTYPE,IMLU,1) 38 : IF (IERR.NE.0) RETURN 39 : * 40 : * ON LIT UN MMODEL OBLIGATOIRE 41 : * 41 : CALL LIROBJ('MMODEL ',IPMODL,1,iret) 42 : IF (IERR.NE.0) RETURN 43 : * 44 : * ON LIT SOIT UN CHAMP POINT, SOIT UN VECTEUR 45 : * 45 : CALL LIROBJ('CHPOINT ',IPCHPS,0,iretch) 46 : IF (IERR.NE.0) RETURN 47 : * 48 : * IF (IPCHPS .EQ. 0) THEN 49 : IF (iretch .EQ. 0) THEN 49 : CALL LIROBJ('POINT ',IPVECT,1,iret) 50 : IF (IERR.NE.0) RETURN 51 : ENDIF 52 : * 53 : *----------------------------------------------------------------------- 54 : * ON A LU LE MOT MASSIF 55 : *----------------------------------------------------------------------- 56 : IF (IMLU.EQ.1) THEN 57 : * 58 : * SI ON A LU UN VECTEUR, IL FAUT LIRE UN MAILLAGE OBLIGATOIREMENT 59 : * 60 : IF (IPVECT .NE. 0) THEN 60 : CALL LIROBJ('MAILLAGE',IPMAIL,1,iret) 61 : IF (IERR.NE.0) RETURN 62 : ENDIF 63 : * 64 : * LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE 65 : * 65 : CALL LIROBJ('MCHAML',IPCARA,0,iret) 66 : IF (IERR.NE.0) RETURN 67 : * 68 : * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES 69 : * 69 : CALL FSURMA(IPMODL,IPCHPS,IPVECT,IPMAIL,IPCARA, IPCHPF) 70 : * 71 : *----------------------------------------------------------------------- 72 : * ON A LU LE MOT COQUE 73 : *----------------------------------------------------------------------- 74 : ELSE IF (IMLU.EQ.2) THEN 75 : * 76 : * LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE 77 : * 77 : CALL LIROBJ('MCHAML',IPCARA,0,iret) 78 : IF (IERR.NE.0) RETURN 79 : * 80 : * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES 81 : * 81 : CALL FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPCHPF) 82 : * 83 : *----------------------------------------------------------------------- 84 : * ON A LU LE MOT POUT 85 : *----------------------------------------------------------------------- 86 : ELSE IF (IMLU.EQ.3) THEN 87 : * 88 : IVPROJ = 0 89 : * 90 : * LECTURE DU MOT-CLE FACULTATIF 'PROJ' 91 : * 91 : CALL LIRMOT(MTYPR,NTYPR,IPROJ,0) 92 : IF (IERR.NE.0) THEN 92 : CALL ERREUR(7) 93 : RETURN 94 : ENDIF 95 : * 96 : * LECTURE DU VECTEUR SI MOT-CLE 'PROJ' A ETE LU 97 : * 98 : IF (IPROJ.EQ.1) THEN 98 : CALL LIROBJ('POINT ',IVPROJ,1,iret) 99 : IF (IERR.NE.0) RETURN 100 : ENDIF 101 : * 102 : * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES 103 : * 103 : CALL FSURPO(IPMODL,IPCHPS,IPVECT,IVPROJ, IPCHPF) 104 : * 105 : ENDIF 106 : * 107 : *----------------------------------------------------------------------- 108 : * FIN DU TRAITEMENT 109 : *----------------------------------------------------------------------- 110 : * 111 : * --> SORTIE PREMATUREE EN CAS D'ERREUR LORS DU CALCUL DES FORCES 112 : * 113 : IF (IERR.NE.0 .OR. IPCHPF.EQ.0) RETURN 114 : * 115 : * --> LE CHAMP DE FORCES NODALES EQUIVALENTES EST DE NATURE DISCRETE 116 : * LE NUMERO DE L HARMONIQUE EST PRIS EGAL A NIFOUR 117 : * POUR TOUTES LES COMPOSANTES DU CHPOINT 118 : * 119 : MCHPOI = IPCHPF 120 : SEGACT,MCHPOI*MOD 121 : NAT = MAX(JATTRI(/1),1) 122 : NSOUPO = IPCHP(/1) 123 : SEGADJ,MCHPOI 124 : JATTRI(1) = 2 125 : DO 10 i = 1, NSOUPO 126 : MSOUPO = IPCHP(i) 127 : SEGACT,MSOUPO*MOD 128 : DO 11 j = 1, NOHARM(/1) 129 : NOHARM(j) = NIFOUR 130 : 11 CONTINUE 131 : SEGDES,MSOUPO 132 : 10 CONTINUE 133 : SEGDES,MCHPOI 134 : * 135 : * --> ECRITURE DU CHPOINT RESULTAT 136 : * 136 : CALL ECROBJ('CHPOINT ',IPCHPF) 137 : * 138 : RETURN 139 : END 140 : 141 :
© Cast3M 2003 - All rights reserved.
Disclaimer