-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdmwprt.f
92 lines (92 loc) · 2.3 KB
/
dmwprt.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
SUBROUTINE DM_WPRT ( iflno, iret )
C************************************************************************
C* DM_WPRT *
C* *
C* This subroutine writes general part information to a DM file. *
C* *
C* DM_WPRT ( IFLNO, IRET ) *
C* *
C* Input parameters: *
C* IFLNO INTEGER File number *
C* *
C* Output parameters: *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -6 = write error *
C** *
C* Log: *
C* M. desJardins/GSFC 3/87 *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'dmcmn.cmn'
C-----------------------------------------------------------------------
iwrite = kppart ( iflno )
nprt = kprt ( iflno )
C
C* Move part names into integer array and write to file.
C
CALL DM_WCH4 ( iflno, iwrite, nprt, kprtnm (1, iflno), iret )
IF ( iret .ne. 0 ) RETURN
iwrite = iwrite + nprt
C
C* Write header lengths, data types and number of parameters.
C
CALL DM_WINT ( iflno, iwrite, nprt, klnhdr (1, iflno), iret )
IF ( iret .ne. 0 ) RETURN
iwrite = iwrite + nprt
C
CALL DM_WINT ( iflno, iwrite, nprt, ktyprt (1, iflno), iret )
IF ( iret .ne. 0 ) RETURN
iwrite = iwrite + nprt
C
CALL DM_WINT ( iflno, iwrite, nprt, kparms (1, iflno), iret )
IF ( iret .ne. 0 ) RETURN
iwrite = iwrite + nprt
C
C* Write parameter names.
C
knt = 0
DO i = 1, nprt
DO j = 1, kparms ( i, iflno )
CALL DM_WCH4 ( iflno, iwrite, 1, kprmnm (j,i,iflno),
+ iret )
iwrite = iwrite + 1
IF ( iret .ne. 0 ) RETURN
END DO
END DO
C
C* Write scale, offset and nbits to file.
C
knt = 0
DO i = 1, nprt
DO j = 1, kparms ( i, iflno )
knt = knt + 1
intarr (knt) = kscale ( j, i, iflno )
END DO
END DO
CALL DM_WINT ( iflno, iwrite, knt, intarr, iret )
IF ( iret .ne. 0 ) RETURN
iwrite = iwrite + knt
C
knt = 0
DO i = 1, nprt
DO j = 1, kparms ( i, iflno )
knt = knt + 1
intarr (knt) = koffst ( j, i, iflno )
END DO
END DO
CALL DM_WINT ( iflno, iwrite, knt, intarr, iret )
IF ( iret .ne. 0 ) RETURN
iwrite = iwrite + knt
C
knt = 0
DO i = 1, nprt
DO j = 1, kparms ( i, iflno )
knt = knt + 1
intarr (knt) = kbits ( j, i, iflno )
END DO
END DO
CALL DM_WINT ( iflno, iwrite, knt, intarr, iret )
C*
RETURN
END