| [135] | 1 | SUBROUTINE to36(x,nbre,xmin,xmax,iunit,icase) |
|---|
| 2 | Ccray IMPLICIT NONE |
|---|
| 3 | IMPLICIT NONE |
|---|
| 4 | c======================================================================= |
|---|
| 5 | c-- x : le champ a compacter |
|---|
| 6 | c-- nbre : la taille du champ x |
|---|
| 7 | c-- iunit: numero logique du fichier sortie |
|---|
| 8 | c-- icase: nombre de cases a utiliser (qui determine la precision) |
|---|
| 9 | INTEGER iunit, nbre, icase |
|---|
| 10 | REAL x(nbre) |
|---|
| 11 | c======================================================================= |
|---|
| 12 | INTEGER ibase, maxnbr, ifact1, ifact2, ifact3 |
|---|
| 13 | PARAMETER (ibase=36, maxnbr=100000) |
|---|
| 14 | PARAMETER (ifact1 = ibase**1-1) |
|---|
| 15 | PARAMETER (ifact2 = ibase**2-1) |
|---|
| 16 | PARAMETER (ifact3 = ibase**3-1) |
|---|
| 17 | c======================================================================= |
|---|
| 18 | CHARACTER*1 word1(0:ifact1) |
|---|
| 19 | COMMON /elbat1/ word1 |
|---|
| 20 | CHARACTER*1 chax1(maxnbr) |
|---|
| 21 | c====================================================================== |
|---|
| 22 | CHARACTER*2 word2(0:ifact2) |
|---|
| 23 | COMMON /elbat2/ word2 |
|---|
| 24 | CHARACTER*2 chax2(maxnbr) |
|---|
| 25 | c====================================================================== |
|---|
| 26 | CHARACTER*3 word3(0:ifact3) |
|---|
| 27 | COMMON /elbat3/ word3 |
|---|
| 28 | CHARACTER*3 chax3(maxnbr) |
|---|
| 29 | c===================================================================== |
|---|
| 30 | INTEGER i, inte |
|---|
| 31 | REAL xmin, xmax |
|---|
| 32 | EXTERNAL ini36 |
|---|
| 33 | c===================================================================== |
|---|
| 34 | c |
|---|
| 35 | c--- initialisation pour le codage |
|---|
| 36 | c la routine ini36 est appelee une seule fois |
|---|
| 37 | c IF (word1(36) .NE. 'Z' ) THEN |
|---|
| 38 | CALL ini36 |
|---|
| 39 | c ENDIF |
|---|
| 40 | |
|---|
| 41 | IF (nbre .GT. maxnbr) THEN |
|---|
| 42 | PRINT*, 'Nombre elements trop grand', nbre, maxnbr |
|---|
| 43 | STOP |
|---|
| 44 | ENDIF |
|---|
| 45 | c |
|---|
| 46 | WRITE(iunit,*) nbre, ibase, icase, ' (nbre,ibase,icase)' |
|---|
| 47 | WRITE(iunit,*) xmin |
|---|
| 48 | WRITE(iunit,*) xmax |
|---|
| 49 | c |
|---|
| 50 | IF(xmin .EQ. xmax)THEN |
|---|
| 51 | WRITE(iunit,'(a)')'Ce champ est constant' |
|---|
| 52 | GO TO 999 |
|---|
| 53 | ENDIF |
|---|
| 54 | c |
|---|
| 55 | IF (icase .EQ. 1) THEN |
|---|
| 56 | DO 10 i = 1, nbre |
|---|
| 57 | inte = NINT( FLOAT(ifact1)/(xmax-xmin) * (x(i)-xmin) ) |
|---|
| 58 | chax1(i) = word1(inte) |
|---|
| 59 | 10 CONTINUE |
|---|
| 60 | WRITE(iunit,91) (chax1(i),i=1,nbre) |
|---|
| 61 | ELSE IF (icase .EQ. 2) THEN |
|---|
| 62 | DO 20 i = 1, nbre |
|---|
| 63 | inte = NINT( FLOAT(ifact2)/(xmax-xmin) * (x(i)-xmin) ) |
|---|
| 64 | chax2(i) = word2(inte) |
|---|
| 65 | 20 CONTINUE |
|---|
| 66 | WRITE(iunit,92) (chax2(i),i=1,nbre) |
|---|
| 67 | ELSE IF (icase.eq.3) THEN |
|---|
| 68 | DO 30 i = 1, nbre |
|---|
| 69 | inte = NINT( FLOAT(ifact3)/(xmax-xmin) * (x(i)-xmin) ) |
|---|
| 70 | chax3(i) = word3(inte) |
|---|
| 71 | 30 CONTINUE |
|---|
| 72 | WRITE(iunit,93) (chax3(i),i=1,nbre) |
|---|
| 73 | ELSE |
|---|
| 74 | PRINT*, 'Verfier icase (1,2,3) dans les arguments de to36' |
|---|
| 75 | STOP |
|---|
| 76 | ENDIF |
|---|
| 77 | c |
|---|
| 78 | 91 FORMAT(120a1) |
|---|
| 79 | 92 FORMAT(64a2) |
|---|
| 80 | 93 FORMAT(40a3) |
|---|
| 81 | c |
|---|
| 82 | 999 RETURN |
|---|
| 83 | END |
|---|
| 84 | |
|---|
