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
104
105
106
107
108
109
110
111
112
113
|
*
* maxstrlen.F
*
* Ansley Manke
* May 2002
*
* Returns max length of strings in input array.
*
* In this subroutine we provide information about
* the function. The user configurable information
* consists of the following:
*
* descr Text description of the function
*
* num_args Required number of arguments
*
* axis_inheritance Type of axis for the result
* ( CUSTOM, IMPLIED_BY_ARGS, NORMAL, maxstrlen )
* CUSTOM - user defined axis
* IMPLIED_BY_ARGS - same axis as the incoming argument
* NORMAL - the result is normal to this axis
* ABSTRACT - an axis which only has index values
*
* piecemeal_ok For memory optimization:
* axes where calculation may be performed piecemeal
* ( YES, NO )
SUBROUTINE maxstrlen_init(id)
INCLUDE 'ferret_cmn/EF_Util.cmn'
INTEGER id, arg
* **********************************************************************
* USER CONFIGURABLE PORTION |
* |
* V
CALL ef_set_desc(id,
. 'Demo Function:Returns the max length of strings in A' )
CALL ef_set_num_args(id, 1)
CALL ef_set_axis_inheritance(id, NORMAL, NORMAL, NORMAL, NORMAL)
CALL ef_set_result_type(id, FLOAT_RETURN)
CALL ef_set_piecemeal_ok(id, YES, YES, YES, YES)
arg = 1
CALL ef_set_axis_influence(id, arg, NO, NO, NO, NO)
CALL ef_set_arg_name(id, arg, 'A')
CALL ef_set_arg_desc(id, arg, 'Array of strings')
CALL ef_set_arg_type (id, arg, STRING_ARG)
* ^
* |
* USER CONFIGURABLE PORTION |
* **********************************************************************
RETURN
END
* In this subroutine we compute the result
*
SUBROUTINE maxstrlen_compute(id, arg_1, result)
INCLUDE 'ferret_cmn/EF_Util.cmn'
INCLUDE 'ferret_cmn/EF_mem_subsc.cmn'
INTEGER id
* Single precision Ferret: string arg and result need to be twice the length.
INTEGER strdf
#ifdef double_p
PARAMETER (strdf = 1)
#else
PARAMETER (strdf = 2)
#endif
REAL arg_1(strdf,mem1lox:mem1hix, mem1loy:mem1hiy,
. mem1loz:mem1hiz, mem1lot:mem1hit)
REAL result(memreslox:memreshix, memresloy:memreshiy,
. memresloz:memreshiz, memreslot:memreshit)
INTEGER res_lo_ss(4), res_hi_ss(4), res_incr(4)
* **********************************************************************
* USER CONFIGURABLE PORTION |
* |
* V
INTEGER atype, iarg, slen
CHARACTER*100 errmsg
CALL ef_get_res_subscripts(id, res_lo_ss, res_hi_ss, res_incr)
CALL ef_get_arg_type (id, 1, atype)
IF (atype .NE. STRING_ARG) THEN
errmsg = 'must call with string argument'
GO TO 5000
ENDIF
iarg = 1
CALL EF_GET_STRING_ARG_MAX_LEN (id, iarg, arg_1, slen)
result(res_lo_ss(X_AXIS), res_lo_ss(Y_AXIS),
. res_lo_ss(Z_AXIS), res_lo_ss(T_AXIS)) = slen
RETURN
5000 CALL EF_BAIL_OUT(id,errmsg)
RETURN
END
|
