-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdmwint.f
103 lines (103 loc) · 2.7 KB
/
dmwint.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
SUBROUTINE DM_WINT ( iflno, isword, nword, idata, iret )
C************************************************************************
C* DM_WINT *
C* *
C* This subroutine writes integer data to a DM file. *
C* *
C* DM_WINT ( IFLNO, ISWORD, NWORD, IDATA, IRET ) *
C* *
C* Input parameters: *
C* IFLNO INTEGER File number *
C* ISWORD INTEGER Start word *
C* NWORD INTEGER Number of words *
C* IDATA (NWORD) INTEGER Data *
C* *
C* Output parameters: *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -6 = write error *
C* -7 = read error *
C** *
C* Log: *
C* M. desJardins/GSFC 6/86 *
C* M. desJardins/GSFC 6/88 Changed to write immediately *
C* M. desJardins/NMC 4/91 Add writes to different machines *
C* M. desJardins/NMC 5/91 Add logical vars for machine types *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'GMBDTA.CMN'
INCLUDE 'dmcmn.cmn'
C
INTEGER idata (*)
C------------------------------------------------------------------------
iret = 0
IF ( nword .le. 0 ) RETURN
C
C* Compute the first record and start word to write.
C
CALL DM_WORD ( isword, irec, jword, ier )
C
C* Loop through records to be written.
C
ileft = nword
knt = 1
DO WHILE ( ileft .gt. 0 )
C
C* Read the next record into the cache.
C
CALL DM_RREC ( iflno, irec, ircpnt, iflerr, ier )
C
C* Move words into the cache buffer.
C
jend = jword + ileft - 1
IF ( jend .gt. MBLKSZ ) jend = MBLKSZ
DO i = jword, jend
kcdata (i,ircpnt) = idata (knt)
knt = knt + 1
END DO
C
C* Translate missing data value, if necessary.
C
IF ( IMISSD .ne. kmissd ( iflno ) ) THEN
DO i = jword, jend
IF ( kcdata (i,ircpnt) .eq. IMISSD )
+ kcdata (i,ircpnt) = kmissd (iflno)
END DO
END IF
C
C* Translate data for different machines.
C
IF ( ( kmachn (iflno) .ne. MTMACH ) .and.
+ ( ( kvmst ( iflno ) .and. ( .not. mvmst ) ) .or.
+ ( mvmst .and. ( .not. kvmst ( iflno ) ) ) ) ) THEN
jsize = jend - jword + 1
ier = MV_SWP4 ( jsize, kcdata (jword,ircpnt),
+ kcdata (jword,ircpnt) )
END IF
C
C* Set flag to indicate buffer should be written to file.
C
C kwrite ( ircpnt ) = .true.
C
C* Write data to file.
C
CALL FL_WRIT ( lundm ( iflno ), irec, MBLKSZ,
+ kcdata ( 1, ircpnt ), iflerr )
C
C* Check error message
C
IF ( iflerr .ne. 0 ) THEN
C CALL ER_WMSG ( 'FL', iflerr, ' ', ier )
iret = -6
END IF
C
C* Update number of words left.
C
ileft = ileft - ( jend - jword + 1 )
irec = irec + 1
jword = 1
C
END DO
C*
RETURN
END