1: PROGRAM main
2:
3: INCLUDE 'pcrc.inc'
4:
5: INTEGER shp_p(1)
6: INTEGER grd_p
7:
8: INTEGER rng_tx1, rng_ty1
9:
10: REAL x(100), y(100)
11: REAL tmp1(100), tmp2(100), tmp3(100), tmp4(100)
12:
13: INTEGER dad_x, dad_y
14: INTEGER dad_tmp1, dad_tmp2, dad_tmp3, dad_tmp4
15: INTEGER dad_ys
16:
17: INTEGER i, ll, lu, ls, amount1, amount2, status1, status2
18: INTEGER i1, i2
19: REAL u1, v1, u2, v2
20:
21: CALL pcrc_init()
22:
23: ! Define processor arrangement
24:
25: shp_p(1) = 4
26: CALL grid_init(1, shp_p, grd_p)
27:
28: ! Define templates
29:
30: rng_tx1 = new_range_distribute(1, 400, grd_p, 1, 1)
31:
32: rng_ty1 = new_range_distribute(-200, 199, grd_p, 1, 1)
33:
34: ! Define main arrays
35:
36: dad_x = new_array_data(x, 2, 4, 1, 1, grd_p)
37: CALL set_array_range_align(dad_x, 1, 2, 99, rng_tx1, 1, 2)
38: CALL set_array_data_done(dad_x)
39:
40: dad_y = new_array_data(y, 2, 4, 1, 1, grd_p)
41: CALL set_array_range_align(dad_y, 1, 1, 100, rng_ty1, -50, 3)
42: CALL set_array_data_done(dad_y)
43:
44: ! Do parallel loop x(i) = 0
45:
46: CALL loop_bounds(rng(dad_x, 1), ll, lu, ls)
47: DO i = ll, lu, ls
48: x (i) = 0
49: END DO
50:
51: ! Do parallel loop y(i) = i
52:
53: CALL loop_bounds(rng(dad_y, 1), ll, lu, ls)
54: DO i = ll, lu, ls
55: y (i) = local_to_global(rng(dad_y, 1), i)
56: END DO
57:
58: ! Define and write temporary for remapped y(i + 1)
59:
60: status1 = detect_communication(dad_x, dad_y, 1, 2, 99, 1, 1, 1, &
61: & u1, v1, amount1)
62:
63: IF(status1 .EQ. 1) THEN
64: dad_tmp1 = new_array_data(tmp1, 2, 4, 1, 1, grd_p)
65: CALL set_array_range_copy(dad_tmp1, 1, rng(dad_y, 1))
66: CALL set_array_data_done(dad_tmp1)
67:
68: CALL shift(dad_tmp1, dad_y, 1, amount1)
69: ELSE IF(status1 .EQ. 2) THEN
70: dad_tmp3 = new_array_data(tmp3, 2, 4, 1, 1, grd_p)
71: CALL set_array_range_copy(dad_tmp3, 1, rng(dad_x, 1))
72: CALL set_array_data_done(dad_tmp3)
73:
74: dad_ys = new_array_section(dad_y)
75: CALL set_array_triplet(dad_ys, 1, dad_y, 1, 3, 100, 1)
76: CALL set_array_section_done(dad_ys)
77:
78: CALL remap(dad_tmp3, dad_ys)
79:
80: CALL delete_array(dad_ys)
81: END IF
82:
83: ! Define and write temporary for remapped y(i - 1)
84:
85: status2 = detect_communication(dad_x, dad_y, 1, 2, 99, 1, 1, -1, &
86: & u2, v2, amount2)
87:
88: IF(status2 .EQ. 1) THEN
89: dad_tmp2 = new_array_data(tmp2, 2, 4, 1, 1, grd_p)
90: CALL set_array_range_copy(dad_tmp2, 1, rng(dad_y, 1))
91: CALL set_array_data_done(dad_tmp2)
92:
93: CALL shift(dad_tmp2, dad_y, 1, amount2)
94: ELSE IF(status2 .EQ. 2) THEN
95: dad_tmp4 = new_array_data(tmp4, 2, 4, 1, 1, grd_p)
96: CALL set_array_range_copy(dad_tmp4, 1, rng(dad_x, 1))
97: CALL set_array_data_done(dad_tmp4)
98:
99: dad_ys = new_array_section(dad_y)
100: CALL set_array_triplet(dad_ys, 1, dad_y, 1, 1, 98, 1)
101: CALL set_array_section_done(dad_ys)
102:
103: CALL remap(dad_tmp4, dad_ys)
104:
105: CALL delete_array(dad_ys)
106: END IF
107:
108: ! Do parallel loop y(i) = y(i+1) + y(i-1)
109:
110: CALL loop_bounds(rng(dad_x, 1), ll, lu, ls)
111: DO i = ll, lu, ls
112: i1 = NINT(u1 * i + v1)
113: i2 = NINT(u2 * i + v2)
114:
115: IF(status1 .EQ. 0 .AND. status2 .EQ. 0) THEN
116: x(i) = y(i1) + y(i2)
117: ELSE IF(status1 .EQ. 0 .AND. status2 .EQ. 1) THEN
118: x(i) = y(i1) + tmp2(i2)
119: ELSE IF(status1 .EQ. 0 .AND. status2 .EQ. 2) THEN
120: x(i) = y(i1) + tmp4(i2)
121: ELSE IF(status1 .EQ. 1 .AND. status2 .EQ. 0) THEN
122: x(i) = tmp1(i1) + y(i2)
123: ELSE IF(status1 .EQ. 1 .AND. status2 .EQ. 1) THEN
124: x(i) = tmp1(i1) + tmp2(i2)
125: ELSE IF(status1 .EQ. 1 .AND. status2 .EQ. 2) THEN
126: x(i) = tmp1(i1) + tmp4(i2)
127: ELSE IF(status1 .EQ. 2 .AND. status2 .EQ. 0) THEN
128: x(i) = tmp3(i1) + y(i2)
129: ELSE IF(status1 .EQ. 2 .AND. status2 .EQ. 1) THEN
130: x(i) = tmp3(i1) + tmp2(i2)
131: ELSE
132: x(i) = tmp3(i1) + tmp4(i2)
133: END IF
134: END DO
135:
136: IF(status1 .EQ. 1) THEN
137: CALL delete_array(dad_tmp1)
138: ELSE IF(status1 .EQ. 2) THEN
139: CALL delete_array(dad_tmp3)
140: END IF
141:
142: IF(status2 .EQ. 1) THEN
143: CALL delete_array(dad_tmp2)
144: ELSE IF(status1 .EQ. 2) THEN
145: CALL delete_array(dad_tmp4)
146: END IF
147:
148: ! Reclaim memory
149:
150: CALL delete_array(dad_y)
151: CALL delete_array(dad_x)
152:
153: CALL delete_range(rng_ty1)
154: CALL delete_range(rng_tx1)
155:
156: CALL pcrc_finalize()
157: END
158: