1 SUBROUTINE ECRITAVOIR(FICH,LFICH,HED,NUMNP,NDSMAX,XYZ,IBC,NODE 2 & ,NPR,NFPR,PR,NGROUP,NTYP,NEL,NDS,NUMSD 3 & ,IMP,IENDIAN,IERR) 4C 5C Ecriture d'un avoir 6C (par routines C -> conversion possible, bid endian, little endian) 7C 8 DIMENSION XYZ(3,*),PR(6,*) 9 INTEGER IBC(9,*),NODE(0:NDSMAX,*),NPR(*),NFPR(6,*) 10 & ,NGROUP(*),NTYP(*),NEL(*),NDS(*) 11 CHARACTER*80 HED,CWORK 12 CHARACTER*128 FICH 13 LOGICAL IFPR 14C 15 REAL*4 WORK(100) 16 INTEGER IWORK(100) 17 EQUIVALENCE (IWORK(1),WORK(1)) 18 EQUIVALENCE (IWORK(1),CWORK) 19C 20 CALL PREMIER_LIBRE(LIBRE) 21 IF (LIBRE.LT.0) THEN 22 PRINT*,'*** Pas d''unit� libre' 23 STOP 24 ENDIF 25C 26 IF (IENDIAN.EQ.1) THEN 27 IOPTEC0 = 0 28 IOPTEC1 = 1 29 ELSE 30 IOPTEC0 = 2 31 IOPTEC1 = 2 32 ENDIF 33 CALL ouvrebin(LIBRE,FICH(1:LFICH)//CHAR(0),1,IERR) 34 IF (IERR.NE.0) THEN 35 PRINT*,'*** Erreur � l''ouverture de '//FICH(1:LFICH) 36 IERR = -1 37 RETURN 38 ENDIF 39 IF (IMP.GT.1) THEN 40 NELTOT = 0 41 DO NS=1,NUMSD 42 NELTOT = NELTOT+NEL(NS) 43 ENDDO 44 NTOTAL = NELTOT+NUMNP 45 NMOD = MAX(1000,NTOTAL/50) 46 CALL INITFLUSH 47 ENDIF 48 CWORK = HED 49 CALL ecritrecbin(LIBRE,IWORK,80,IOPTEC1) 50 IWORK(1) = NUMNP 51 IWORK(2) = 8 52 CALL ecritrecbin(LIBRE,IWORK,8,IOPTEC0) 53C 54 IF (IENDIAN.EQ.1) THEN 55 DO I=1,NUMNP 56 WORK(1) = XYZ(1,I) 57 WORK(2) = XYZ(2,I) 58 WORK(3) = XYZ(3,I) 59 DO K=1,9 60 IWORK(K+3) = IBC(K,I) 61 ENDDO 62 CALL ecritrecbin(LIBRE,IWORK,48,IOPTEC0) 63 IF (IMP.GT.1) THEN 64 IF (MOD(I,NMOD).EQ.0) 65 & CALL MYFLUSH(100.*REAL(I)/REAL(NTOTAL)) 66 ENDIF 67 ENDDO 68 ELSE 69 DO I=1,NUMNP 70 WORK(1) = XYZ(1,I) 71 WORK(2) = XYZ(2,I) 72 WORK(3) = XYZ(3,I) 73 DO K=1,9 74 IWORK(K+3) = IBC(K,I) 75 ENDDO 76 CALL ecritrecbinspeed(LIBRE,IWORK,48) 77 IF (IMP.GT.1) THEN 78 IF (MOD(I,NMOD).EQ.0) 79 & CALL MYFLUSH(100.*REAL(I)/REAL(NTOTAL)) 80 ENDIF 81 ENDDO 82 ENDIF 83 N = 0 84 DO NS=1,NUMSD 85 IWORK(1) = NGROUP(NS) 86 IWORK(2) = NTYP(NS) 87 IWORK(3) = NEL(NS) 88 IWORK(4) = NDS(NS) 89 CALL ecritrecbin(LIBRE,IWORK,16,IOPTEC0) 90 LLL0 = 4*(NDS(NS)+1) 91 LLL = LLL0 92 IFPR = NDS(NS).EQ.3.OR.NDS(NS).EQ.4.OR.NDS(NS).EQ.8 93 & .OR.NDS(NS).EQ.6.OR.NDS(NS).EQ.16 94 IF (IENDIAN.EQ.1) THEN 95 DO I=1,NEL(NS) 96 N = N+1 97 DO K=0,NDS(NS) 98 IWORK(K+1) = NODE(K,N) 99 ENDDO 100 IF (IFPR) THEN 101 IWORK(NDS(NS)+2) = NPR(N) 102 IF (NPR(N).GT.0) THEN 103 DO K=1,NPR(N) 104 IWORK(NDS(NS)+1+2*K) = NFPR(K,N) 105 WORK(NDS(NS)+2+2*K) = PR(K,N) 106 ENDDO 107 ENDIF 108 LLL = LLL0+4*(1+NPR(N)*2) 109 ENDIF 110 CALL ecritrecbin(LIBRE,IWORK,LLL,IOPTEC0) 111 IF (IMP.GT.1) THEN 112 IF (MOD(N+NUMNP,NMOD).EQ.0) 113 & CALL MYFLUSH(100.*REAL(N+NUMNP)/REAL(NTOTAL)) 114 ENDIF 115 ENDDO 116 ELSE 117 DO I=1,NEL(NS) 118 N = N+1 119 DO K=0,NDS(NS) 120 IWORK(K+1) = NODE(K,N) 121 ENDDO 122 IF (IFPR) THEN 123 IWORK(NDS(NS)+2) = NPR(N) 124 IF (NPR(N).GT.0) THEN 125 DO K=1,NPR(N) 126 IWORK(NDS(NS)+1+2*K) = NFPR(K,N) 127 WORK(NDS(NS)+2+2*K) = PR(K,N) 128 ENDDO 129 ENDIF 130 LLL = LLL0+4*(1+NPR(N)*2) 131 ENDIF 132 CALL ecritrecbinspeed(LIBRE,IWORK,LLL) 133 IF (IMP.GT.1) THEN 134 IF (MOD(N+NUMNP,NMOD).EQ.0) 135 & CALL MYFLUSH(100.*REAL(N+NUMNP)/REAL(NTOTAL)) 136 ENDIF 137 ENDDO 138 ENDIF 139 ENDDO 140 CALL fermebin(LIBRE) 141 IF (IMP.GT.1) CALL ENDFLUSH 142 END 143C--------------------------------------------------------------------- 144 SUBROUTINE ECRITAVOIR0(FICH,LFICH,HED,NUMNP,NDSMAX,XYZ,IBC,NODE 145 & ,NPR,NFPR,PR,NGROUP,NTYP,NEL,NDS,NUMSD,IMP 146 & ,IERR) 147 DIMENSION XYZ(3,*),PR(6,*) 148 INTEGER IBC(9,*),NODE(0:NDSMAX,*),NPR(*),NFPR(6,*) 149 & ,NGROUP(*),NTYP(*),NEL(*),NDS(*) 150 CHARACTER*80 HED 151 CHARACTER*128 FICH 152 LOGICAL IFPR 153C 154C Version avec ecriture fortran (tres lente) 155C 156 CALL PREMIER_LIBRE(LIBRE) 157 IF (LIBRE.LT.0) THEN 158 PRINT*,'*** Pas d''unit� libre' 159 STOP 160 ENDIF 161C 162 OPEN(LIBRE,FILE=FICH(1:LFICH),FORM='UNFORMATTED',IOSTAT=IERR) 163 IF (IERR.NE.0) THEN 164 PRINT*,'*** Erreur � l''ouverture de '//FICH(1:LFICH) 165 IERR = -1 166 RETURN 167 ENDIF 168C 169 IF (IMP.GT.1) THEN 170 NELTOT = 0 171 DO NS=1,NUMSD 172 NELTOT = NELTOT+NEL(NS) 173 ENDDO 174 NTOTAL = NELTOT+NUMNP 175 NMOD = MAX(1000,NTOTAL/50) 176 CALL INITFLUSH 177 ENDIF 178C 179 WRITE(LIBRE) HED 180 WRITE(LIBRE) NUMNP,8 181 DO I=1,NUMNP 182 WRITE(LIBRE) (XYZ(K,I),K=1,3),(IBC(K,I),K=1,9) 183 IF (IMP.GT.1) THEN 184 IF (MOD(I,NMOD).EQ.0) 185 & CALL MYFLUSH(100.*REAL(I)/REAL(NTOTAL)) 186 ENDIF 187 ENDDO 188 N = 0 189 DO NS=1,NUMSD 190 WRITE(LIBRE) NGROUP(NS),NTYP(NS),NEL(NS),NDS(NS) 191 IFPR = NDS(NS).EQ.3.OR.NDS(NS).EQ.4.OR.NDS(NS).EQ.8 192 & .OR.NDS(NS).EQ.6.OR.NDS(NS).EQ.16 193 DO I=1,NEL(NS) 194 N = N+1 195 IF (IFPR) THEN 196 IF (NPR(N).GT.0) THEN 197 WRITE(LIBRE) (NODE(K,N),K=0,NDS(NS)),NPR(N) 198 & ,(NFPR(K,N),PR(K,N),K=1,NPR(N)) 199 ELSE 200 WRITE(LIBRE) (NODE(K,N),K=0,NDS(NS)),0 201 ENDIF 202 ELSE 203 WRITE(LIBRE) (NODE(K,N),K=0,NDS(NS)) 204 ENDIF 205 IF (IMP.GT.1) THEN 206 IF (MOD(N+NUMNP,NMOD).EQ.0) 207 & CALL MYFLUSH(100.*REAL(N+NUMNP)/REAL(NTOTAL)) 208 ENDIF 209 ENDDO 210 ENDDO 211 CLOSE(LIBRE) 212 IF (IMP.GT.1) CALL ENDFLUSH 213 END 214C--------------------------------------------------------------------- 215 SUBROUTINE ECRITAVOIREASY(FICH,LFICH,HED,NUMNP,NEL,NDS,NDSM,X,Y,Z 216 & ,IBC,NODE,IERR) 217C 218C Ecriture d'un avoir version simplifiee. Un seul sous-domaine 219C pas de pressions, pas de traduction 220C 221 DIMENSION X(*),Y(*),Z(*) 222 INTEGER IBC(9,*),NODE(NDSM,*) 223 CHARACTER*80 HED,CWORK 224 CHARACTER*128 FICH 225 LOGICAL IFPR 226C 227 REAL*4 WORK(50) 228 INTEGER IWORK(50) 229 EQUIVALENCE (IWORK(1),WORK(1)) 230 EQUIVALENCE (IWORK(1),CWORK) 231C 232 CALL PREMIER_LIBRE(LIBRE) 233 IF (LIBRE.LT.0) THEN 234 PRINT*,'*** Pas d''unit� libre' 235 STOP 236 ENDIF 237C 238 CALL ouvrebin(LIBRE,FICH(1:LFICH)//CHAR(0),1,IERR) 239 IF (IERR.NE.0) THEN 240 PRINT*,'*** Erreur � l''ouverture de '//FICH(1:LFICH) 241 IERR = -1 242 RETURN 243 ENDIF 244 CWORK = HED 245 CALL ecritrecbinspeed(LIBRE,IWORK,80) 246 IWORK(1) = NUMNP 247 IWORK(2) = 8 248 CALL ecritrecbinspeed(LIBRE,IWORK,8) 249C 250 DO I=1,NUMNP 251 WORK(1) = X(I) 252 WORK(2) = Y(I) 253 WORK(3) = Z(I) 254 DO K=1,9 255 IWORK(K+3) = IBC(K,I) 256 ENDDO 257 CALL ecritrecbinspeed(LIBRE,IWORK,48) 258 ENDDO 259 IWORK(1) = 1 260 IWORK(2) = 1 261 IWORK(3) = NEL 262 IWORK(4) = NDS 263 CALL ecritrecbinspeed(LIBRE,IWORK,16) 264 IFPR = NDS.EQ.3.OR.NDS.EQ.4.OR.NDS.EQ.8 265 & .OR.NDS.EQ.6.OR.NDS.EQ.16 266 IF (IFPR) THEN 267 LLL = 4*(NDS+2) 268 ELSE 269 LLL = 4*(NDS+1) 270 ENDIF 271 DO N=1,NEL 272 IWORK(1) = N 273 DO K=1,NDS 274 IWORK(K+1) = NODE(K,N) 275 ENDDO 276 IF (IFPR) IWORK(NDS+2) = 0 277 CALL ecritrecbinspeed(LIBRE,IWORK,LLL) 278 ENDDO 279 CALL fermebin(LIBRE) 280 END 281