-
Notifications
You must be signed in to change notification settings - Fork 0
/
module_domain.f90
2994 lines (2704 loc) · 134 KB
/
module_domain.f90
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
!WRF:DRIVER_LAYER:DOMAIN_OBJECT
!
! Following are the routines contained within this MODULE:
! alloc_and_configure_domain 1. Allocate the space for a single domain (constants
! and null terminate pointers).
! 2. Connect the domains as a linked list.
! 3. Store all of the domain constants.
! 4. CALL alloc_space_field.
! alloc_space_field 1. Allocate space for the gridded data required for
! each domain.
! dealloc_space_domain 1. Reconnect linked list nodes since the current
! node is removed.
! 2. CALL dealloc_space_field.
! 3. Deallocate single domain.
! dealloc_space_field 1. Deallocate each of the fields for a particular
! domain.
! first_loc_integer 1. Find the first incidence of a particular
! domain identifier from an array of domain
! identifiers.
MODULE module_domain
USE module_driver_constants
USE module_machine
USE module_configure
USE module_wrf_error
USE module_utility
USE module_domain_type
! In WRFV3, the module_domain_type is defined
! in a separaate source file, frame/module_domain_type.F
! This enables splitting off the alloc_space_field routine
! into a separate file, reducing the size of module_domain
! Now that a "domain" TYPE exists, we can use it to store a few pointers
! to this type. These are primarily for use in traversing the linked list.
! The "head_grid" is always the pointer to the first domain that is
! allocated. This is available and is not to be changed. The others are
! just temporary pointers.
TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid
! To facilitate an easy integration of each of the domains that are on the
! same level, we have an array for the head pointer for each level. This
! removed the need to search through the linked list at each time step to
! find which domains are to be active.
TYPE domain_levels
TYPE(domain) , POINTER :: first_domain
END TYPE domain_levels
TYPE(domain_levels) , DIMENSION(max_levels) :: head_for_each_level
! Use this to support debugging features, giving easy access to clock, etc.
TYPE(domain), POINTER :: current_grid
LOGICAL, SAVE :: current_grid_set = .FALSE.
#if ( WRF_PLANET == 1 )
! The limit on the number of variables that can be changed in the
! "iofields_filename" file when setting variables for an input/output stream
INTEGER, PARAMETER, PRIVATE :: MAX_DEXES = 1000
#endif
! internal routines
PRIVATE domain_time_test_print
PRIVATE test_adjust_io_timestr
INTERFACE get_ijk_from_grid
MODULE PROCEDURE get_ijk_from_grid1, get_ijk_from_grid2
END INTERFACE
CONTAINS
SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy )
IMPLICIT NONE
TYPE( domain ), POINTER :: grid
INTEGER, INTENT(IN) :: dx, dy
data_ordering : SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
grid%sm31 = grid%sm31 + dx
grid%em31 = grid%em31 + dx
grid%sm32 = grid%sm32 + dy
grid%em32 = grid%em32 + dy
grid%sp31 = grid%sp31 + dx
grid%ep31 = grid%ep31 + dx
grid%sp32 = grid%sp32 + dy
grid%ep32 = grid%ep32 + dy
grid%sd31 = grid%sd31 + dx
grid%ed31 = grid%ed31 + dx
grid%sd32 = grid%sd32 + dy
grid%ed32 = grid%ed32 + dy
CASE ( DATA_ORDER_YXZ )
grid%sm31 = grid%sm31 + dy
grid%em31 = grid%em31 + dy
grid%sm32 = grid%sm32 + dx
grid%em32 = grid%em32 + dx
grid%sp31 = grid%sp31 + dy
grid%ep31 = grid%ep31 + dy
grid%sp32 = grid%sp32 + dx
grid%ep32 = grid%ep32 + dx
grid%sd31 = grid%sd31 + dy
grid%ed31 = grid%ed31 + dy
grid%sd32 = grid%sd32 + dx
grid%ed32 = grid%ed32 + dx
CASE ( DATA_ORDER_ZXY )
grid%sm32 = grid%sm32 + dx
grid%em32 = grid%em32 + dx
grid%sm33 = grid%sm33 + dy
grid%em33 = grid%em33 + dy
grid%sp32 = grid%sp32 + dx
grid%ep32 = grid%ep32 + dx
grid%sp33 = grid%sp33 + dy
grid%ep33 = grid%ep33 + dy
grid%sd32 = grid%sd32 + dx
grid%ed32 = grid%ed32 + dx
grid%sd33 = grid%sd33 + dy
grid%ed33 = grid%ed33 + dy
CASE ( DATA_ORDER_ZYX )
grid%sm32 = grid%sm32 + dy
grid%em32 = grid%em32 + dy
grid%sm33 = grid%sm33 + dx
grid%em33 = grid%em33 + dx
grid%sp32 = grid%sp32 + dy
grid%ep32 = grid%ep32 + dy
grid%sp33 = grid%sp33 + dx
grid%ep33 = grid%ep33 + dx
grid%sd32 = grid%sd32 + dy
grid%ed32 = grid%ed32 + dy
grid%sd33 = grid%sd33 + dx
grid%ed33 = grid%ed33 + dx
CASE ( DATA_ORDER_XZY )
grid%sm31 = grid%sm31 + dx
grid%em31 = grid%em31 + dx
grid%sm33 = grid%sm33 + dy
grid%em33 = grid%em33 + dy
grid%sp31 = grid%sp31 + dx
grid%ep31 = grid%ep31 + dx
grid%sp33 = grid%sp33 + dy
grid%ep33 = grid%ep33 + dy
grid%sd31 = grid%sd31 + dx
grid%ed31 = grid%ed31 + dx
grid%sd33 = grid%sd33 + dy
grid%ed33 = grid%ed33 + dy
CASE ( DATA_ORDER_YZX )
grid%sm31 = grid%sm31 + dy
grid%em31 = grid%em31 + dy
grid%sm33 = grid%sm33 + dx
grid%em33 = grid%em33 + dx
grid%sp31 = grid%sp31 + dy
grid%ep31 = grid%ep31 + dy
grid%sp33 = grid%sp33 + dx
grid%ep33 = grid%ep33 + dx
grid%sd31 = grid%sd31 + dy
grid%ed31 = grid%ed31 + dy
grid%sd33 = grid%sd33 + dx
grid%ed33 = grid%ed33 + dx
END SELECT data_ordering
#if 0
CALL dealloc_space_field ( grid )
CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. , &
grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, &
grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, &
grid%sp31x, grid%ep31x, grid%sp32x, grid%ep32x, grid%sp33x, grid%ep33x, &
grid%sp31y, grid%ep31y, grid%sp32y, grid%ep32y, grid%sp33y, grid%ep33y, &
grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose
grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose
)
#endif
RETURN
END SUBROUTINE adjust_domain_dims_for_move
#if 1
SUBROUTINE get_ijk_from_grid1 ( grid , &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
imsx, imex, jmsx, jmex, kmsx, kmex, &
ipsx, ipex, jpsx, jpex, kpsx, kpex, &
imsy, imey, jmsy, jmey, kmsy, kmey, &
ipsy, ipey, jpsy, jpey, kpsy, kpey )
IMPLICIT NONE
TYPE( domain ), INTENT (IN) :: grid
INTEGER, INTENT(OUT) :: &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
imsx, imex, jmsx, jmex, kmsx, kmex, &
ipsx, ipex, jpsx, jpex, kpsx, kpex, &
imsy, imey, jmsy, jmey, kmsy, kmey, &
ipsy, ipey, jpsy, jpey, kpsy, kpey
CALL get_ijk_from_grid2 ( grid , &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe )
data_ordering : SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
CASE ( DATA_ORDER_YXZ )
imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
CASE ( DATA_ORDER_ZXY )
imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
CASE ( DATA_ORDER_ZYX )
imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
CASE ( DATA_ORDER_XZY )
imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
CASE ( DATA_ORDER_YZX )
imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
END SELECT data_ordering
END SUBROUTINE get_ijk_from_grid1
SUBROUTINE get_ijk_from_grid2 ( grid , &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe )
IMPLICIT NONE
TYPE( domain ), INTENT (IN) :: grid
INTEGER, INTENT(OUT) :: &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe
data_ordering : SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ;
ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ;
ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp33 ; kpe = grid%ep33 ;
CASE ( DATA_ORDER_YXZ )
ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd33 ; kde = grid%ed33 ;
ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm33 ; kme = grid%em33 ;
ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp33 ; kpe = grid%ep33 ;
CASE ( DATA_ORDER_ZXY )
ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd31 ; kde = grid%ed31 ;
ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm31 ; kme = grid%em31 ;
ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp31 ; kpe = grid%ep31 ;
CASE ( DATA_ORDER_ZYX )
ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd31 ; kde = grid%ed31 ;
ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm31 ; kme = grid%em31 ;
ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp31 ; kpe = grid%ep31 ;
CASE ( DATA_ORDER_XZY )
ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd32 ; kde = grid%ed32 ;
ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm32 ; kme = grid%em32 ;
ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp32 ; kpe = grid%ep32 ;
CASE ( DATA_ORDER_YZX )
ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd32 ; kde = grid%ed32 ;
ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm32 ; kme = grid%em32 ;
ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp32 ; kpe = grid%ep32 ;
END SELECT data_ordering
END SUBROUTINE get_ijk_from_grid2
! return the values for subgrid whose refinement is in grid%sr
! note when using this routine, it does not affect K. For K
! (vertical), it just returns what get_ijk_from_grid does
SUBROUTINE get_ijk_from_subgrid ( grid , &
ids0, ide0, jds0, jde0, kds0, kde0, &
ims0, ime0, jms0, jme0, kms0, kme0, &
ips0, ipe0, jps0, jpe0, kps0, kpe0 )
TYPE( domain ), INTENT (IN) :: grid
INTEGER, INTENT(OUT) :: &
ids0, ide0, jds0, jde0, kds0, kde0, &
ims0, ime0, jms0, jme0, kms0, kme0, &
ips0, ipe0, jps0, jpe0, kps0, kpe0
! Local
INTEGER :: &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe
CALL get_ijk_from_grid ( grid , &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe )
ids0 = ids
ide0 = ide * grid%sr_x
ims0 = (ims-1)*grid%sr_x+1
ime0 = ime * grid%sr_x
ips0 = (ips-1)*grid%sr_x+1
ipe0 = ipe * grid%sr_x
jds0 = jds
jde0 = jde * grid%sr_y
jms0 = (jms-1)*grid%sr_y+1
jme0 = jme * grid%sr_y
jps0 = (jps-1)*grid%sr_y+1
jpe0 = jpe * grid%sr_y
kds0 = kds
kde0 = kde
kms0 = kms
kme0 = kme
kps0 = kps
kpe0 = kpe
RETURN
END SUBROUTINE get_ijk_from_subgrid
#endif
! Default version ; Otherwise module containing interface to DM library will provide
SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , &
sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
sp1x , ep1x , sm1x , em1x , &
sp2x , ep2x , sm2x , em2x , &
sp3x , ep3x , sm3x , em3x , &
sp1y , ep1y , sm1y , em1y , &
sp2y , ep2y , sm2y , em2y , &
sp3y , ep3y , sm3y , em3y , &
bdx , bdy , bdy_mask )
!<DESCRIPTION>
! Wrf_patch_domain is called as part of the process of initiating a new
! domain. Based on the global domain dimension information that is
! passed in it computes the patch and memory dimensions on this
! distributed-memory process for parallel compilation when DM_PARALLEL is
! defined in configure.wrf. In this case, it relies on an external
! communications package-contributed routine, wrf_dm_patch_domain. For
! non-parallel compiles, it returns the patch and memory dimensions based
! on the entire domain. In either case, the memory dimensions will be
! larger than the patch dimensions, since they allow for distributed
! memory halo regions (DM_PARALLEL only) and for boundary regions around
! the domain (used for idealized cases only). The width of the boundary
! regions to be accommodated is passed in as bdx and bdy.
!
! The bdy_mask argument is a four-dimensional logical array, each element
! of which is set to true for any boundaries that this process's patch
! contains (all four are true in the non-DM_PARALLEL case) and false
! otherwise. The indices into the bdy_mask are defined in
! frame/module_state_description.F. P_XSB corresponds boundary that
! exists at the beginning of the X-dimension; ie. the western boundary;
! P_XEB to the boundary that corresponds to the end of the X-dimension
! (east). Likewise for Y (south and north respectively).
!
! The correspondence of the first, second, and third dimension of each
! set (domain, memory, and patch) with the coordinate axes of the model
! domain is based on the setting of the variable model_data_order, which
! comes into this routine through USE association of
! module_driver_constants in the enclosing module of this routine,
! module_domain. Model_data_order is defined by the Registry, based on
! the dimspec entries which associate dimension specifiers (e.g. 'k') in
! the Registry with a coordinate axis and specify which dimension of the
! arrays they represent. For WRF, the sd1 , ed1 , sp1 , ep1 , sm1 , and
! em1 correspond to the starts and ends of the global, patch, and memory
! dimensions in X; those with 2 specify Z (vertical); and those with 3
! specify Y. Note that the WRF convention is to overdimension to allow
! for staggered fields so that sd<em>n</em>:ed<em>n</em> are the starts
! and ends of the staggered domains in X. The non-staggered grid runs
! sd<em>n</em>:ed<em>n</em>-1. The extra row or column on the north or
! east boundaries is not used for non-staggered fields.
!
! The domdesc and parent_domdesc arguments are for external communication
! packages (e.g. RSL) that establish and return to WRF integer handles
! for referring to operations on domains. These descriptors are not set
! or used otherwise and they are opaque, which means they are never
! accessed or modified in WRF; they are only only passed between calls to
! the external package.
!</DESCRIPTION>
USE module_machine
IMPLICIT NONE
LOGICAL, DIMENSION(4), INTENT(OUT) :: bdy_mask
INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , & ! z-xpose (std)
sm1 , em1 , sm2 , em2 , sm3 , em3
INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , & ! x-xpose
sm1x , em1x , sm2x , em2x , sm3x , em3x
INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , & ! y-xpose
sm1y , em1y , sm2y , em2y , sm3y , em3y
INTEGER, INTENT(IN) :: id , parent_id , parent_domdesc
INTEGER, INTENT(INOUT) :: domdesc
TYPE(domain), POINTER :: parent
!local data
INTEGER spec_bdy_width
CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
#ifndef DM_PARALLEL
bdy_mask = .true. ! only one processor so all 4 boundaries are there
! this is a trivial version -- 1 patch per processor;
! use version in module_dm to compute for DM
sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3
ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3
SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
sm1 = sp1 - bdx ; em1 = ep1 + bdx
sm2 = sp2 - bdy ; em2 = ep2 + bdy
sm3 = sp3 ; em3 = ep3
CASE ( DATA_ORDER_YXZ )
sm1 = sp1 - bdy ; em1 = ep1 + bdy
sm2 = sp2 - bdx ; em2 = ep2 + bdx
sm3 = sp3 ; em3 = ep3
CASE ( DATA_ORDER_ZXY )
sm1 = sp1 ; em1 = ep1
sm2 = sp2 - bdx ; em2 = ep2 + bdx
sm3 = sp3 - bdy ; em3 = ep3 + bdy
CASE ( DATA_ORDER_ZYX )
sm1 = sp1 ; em1 = ep1
sm2 = sp2 - bdy ; em2 = ep2 + bdy
sm3 = sp3 - bdx ; em3 = ep3 + bdx
CASE ( DATA_ORDER_XZY )
sm1 = sp1 - bdx ; em1 = ep1 + bdx
sm2 = sp2 ; em2 = ep2
sm3 = sp3 - bdy ; em3 = ep3 + bdy
CASE ( DATA_ORDER_YZX )
sm1 = sp1 - bdy ; em1 = ep1 + bdy
sm2 = sp2 ; em2 = ep2
sm3 = sp3 - bdx ; em3 = ep3 + bdx
END SELECT
sm1x = sm1 ; em1x = em1 ! just copy
sm2x = sm2 ; em2x = em2
sm3x = sm3 ; em3x = em3
sm1y = sm1 ; em1y = em1 ! just copy
sm2y = sm2 ; em2y = em2
sm3y = sm3 ; em3y = em3
! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned
sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3
sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3
#else
! This is supplied by the package specific version of module_dm, which
! is supplied by the external package and copied into the src directory
! when the code is compiled. The cp command will be found in the externals
! target of the configure.wrf file for this architecture. Eg: for RSL
! routine is defined in external/RSL/module_dm.F .
! Note, it would be very nice to be able to pass parent to this routine;
! however, there doesn't seem to be a way to do that in F90. That is because
! to pass a pointer to a domain structure, this call requires an interface
! definition for wrf_dm_patch_domain (otherwise it will try to convert the
! pointer to something). In order to provide an interface definition, we
! would need to either USE module_dm or use an interface block. In either
! case it generates a circular USE reference, since module_dm uses
! module_domain. JM 20020416
CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , &
sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
sp1x , ep1x , sm1x , em1x , &
sp2x , ep2x , sm2x , em2x , &
sp3x , ep3x , sm3x , em3x , &
sp1y , ep1y , sm1y , em1y , &
sp2y , ep2y , sm2y , em2y , &
sp3y , ep3y , sm3y , em3y , &
bdx , bdy )
SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
bdy_mask( P_XSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
bdy_mask( P_YSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 )
bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 )
CASE ( DATA_ORDER_YXZ )
bdy_mask( P_XSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
bdy_mask( P_YSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 )
bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 )
CASE ( DATA_ORDER_ZXY )
bdy_mask( P_XSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
bdy_mask( P_YSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 )
bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 )
CASE ( DATA_ORDER_ZYX )
bdy_mask( P_XSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
bdy_mask( P_YSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 )
bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 )
CASE ( DATA_ORDER_XZY )
bdy_mask( P_XSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
bdy_mask( P_YSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 )
bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 )
CASE ( DATA_ORDER_YZX )
bdy_mask( P_XSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
bdy_mask( P_YSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 )
bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 )
END SELECT
#endif
RETURN
END SUBROUTINE wrf_patch_domain
!
SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid )
!<DESCRIPTION>
! This subroutine is used to allocate a domain data structure of
! TYPE(DOMAIN) pointed to by the argument <em>grid</em>, link it into the
! nested domain hierarchy, and set it's configuration information from
! the appropriate settings in the WRF namelist file. Specifically, if the
! domain being allocated and configured is nest, the <em>parent</em>
! argument will point to the already existing domain data structure for
! the parent domain and the <em>kid</em> argument will be set to an
! integer indicating which child of the parent this grid will be (child
! indices start at 1). If this is the top-level domain, the parent and
! kid arguments are ignored. <b>WRF domains may have multiple children
! but only ever have one parent.</b>
!
! The <em>domain_id</em> argument is the
! integer handle by which this new domain will be referred; it comes from
! the grid_id setting in the namelist, and these grid ids correspond to
! the ordering of settings in the namelist, starting with 1 for the
! top-level domain. The id of 1 always corresponds to the top-level
! domain. and these grid ids correspond to the ordering of settings in
! the namelist, starting with 1 for the top-level domain.
!
! Model_data_order is provide by USE association of
! module_driver_constants and is set from dimspec entries in the
! Registry.
!
! The allocation of the TYPE(DOMAIN) itself occurs in this routine.
! However, the numerous multi-dimensional arrays that make up the members
! of the domain are allocated in the call to alloc_space_field, after
! wrf_patch_domain has been called to determine the dimensions in memory
! that should be allocated. It bears noting here that arrays and code
! that indexes these arrays are always global, regardless of how the
! model is decomposed over patches. Thus, when arrays are allocated on a
! given process, the start and end of an array dimension are the global
! indices of the start and end of that process's subdomain.
!
! Configuration information for the domain (that is, information from the
! namelist) is added by the call to <a href=med_add_config_info_to_grid.html>med_add_config_info_to_grid</a>, defined
! in share/mediation_wrfmain.F.
!</DESCRIPTION>
IMPLICIT NONE
! Input data.
INTEGER , INTENT(IN) :: domain_id
TYPE( domain ) , POINTER :: grid
TYPE( domain ) , POINTER :: parent
INTEGER , INTENT(IN) :: kid ! which kid of parent am I?
! Local data.
INTEGER :: sd1 , ed1 , sp1 , ep1 , sm1 , em1
INTEGER :: sd2 , ed2 , sp2 , ep2 , sm2 , em2
INTEGER :: sd3 , ed3 , sp3 , ep3 , sm3 , em3
INTEGER :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x
INTEGER :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x
INTEGER :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x
INTEGER :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y
INTEGER :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y
INTEGER :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y
TYPE(domain) , POINTER :: new_grid
INTEGER :: i
INTEGER :: parent_id , parent_domdesc , new_domdesc
INTEGER :: bdyzone_x , bdyzone_y
INTEGER :: nx, ny
! This next step uses information that is listed in the registry as namelist_derived
! to properly size the domain and the patches; this in turn is stored in the new_grid
! data structure
data_ordering : SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
CALL nl_get_s_we( domain_id , sd1 )
CALL nl_get_e_we( domain_id , ed1 )
CALL nl_get_s_sn( domain_id , sd2 )
CALL nl_get_e_sn( domain_id , ed2 )
CALL nl_get_s_vert( domain_id , sd3 )
CALL nl_get_e_vert( domain_id , ed3 )
nx = ed1-sd1+1
ny = ed2-sd2+1
CASE ( DATA_ORDER_YXZ )
CALL nl_get_s_sn( domain_id , sd1 )
CALL nl_get_e_sn( domain_id , ed1 )
CALL nl_get_s_we( domain_id , sd2 )
CALL nl_get_e_we( domain_id , ed2 )
CALL nl_get_s_vert( domain_id , sd3 )
CALL nl_get_e_vert( domain_id , ed3 )
nx = ed2-sd2+1
ny = ed1-sd1+1
CASE ( DATA_ORDER_ZXY )
CALL nl_get_s_vert( domain_id , sd1 )
CALL nl_get_e_vert( domain_id , ed1 )
CALL nl_get_s_we( domain_id , sd2 )
CALL nl_get_e_we( domain_id , ed2 )
CALL nl_get_s_sn( domain_id , sd3 )
CALL nl_get_e_sn( domain_id , ed3 )
nx = ed2-sd2+1
ny = ed3-sd3+1
CASE ( DATA_ORDER_ZYX )
CALL nl_get_s_vert( domain_id , sd1 )
CALL nl_get_e_vert( domain_id , ed1 )
CALL nl_get_s_sn( domain_id , sd2 )
CALL nl_get_e_sn( domain_id , ed2 )
CALL nl_get_s_we( domain_id , sd3 )
CALL nl_get_e_we( domain_id , ed3 )
nx = ed3-sd3+1
ny = ed2-sd2+1
CASE ( DATA_ORDER_XZY )
CALL nl_get_s_we( domain_id , sd1 )
CALL nl_get_e_we( domain_id , ed1 )
CALL nl_get_s_vert( domain_id , sd2 )
CALL nl_get_e_vert( domain_id , ed2 )
CALL nl_get_s_sn( domain_id , sd3 )
CALL nl_get_e_sn( domain_id , ed3 )
nx = ed1-sd1+1
ny = ed3-sd3+1
CASE ( DATA_ORDER_YZX )
CALL nl_get_s_sn( domain_id , sd1 )
CALL nl_get_e_sn( domain_id , ed1 )
CALL nl_get_s_vert( domain_id , sd2 )
CALL nl_get_e_vert( domain_id , ed2 )
CALL nl_get_s_we( domain_id , sd3 )
CALL nl_get_e_we( domain_id , ed3 )
nx = ed3-sd3+1
ny = ed1-sd1+1
END SELECT data_ordering
IF ( num_time_levels > 3 ) THEN
WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', &
'Incorrect value for num_time_levels ', num_time_levels
CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
ENDIF
IF (ASSOCIATED(parent)) THEN
parent_id = parent%id
parent_domdesc = parent%domdesc
ELSE
parent_id = -1
parent_domdesc = -1
ENDIF
! provided by application, WRF defines in share/module_bc.F
CALL get_bdyzone_x( bdyzone_x )
CALL get_bdyzone_y( bdyzone_y )
ALLOCATE ( new_grid )
ALLOCATE( new_grid%head_statevars )
NULLIFY( new_grid%head_statevars%next)
new_grid%tail_statevars => new_grid%head_statevars
ALLOCATE ( new_grid%parents( max_parents ) )
ALLOCATE ( new_grid%nests( max_nests ) )
NULLIFY( new_grid%sibling )
DO i = 1, max_nests
NULLIFY( new_grid%nests(i)%ptr )
ENDDO
NULLIFY (new_grid%next)
NULLIFY (new_grid%same_level)
NULLIFY (new_grid%i_start)
NULLIFY (new_grid%j_start)
NULLIFY (new_grid%i_end)
NULLIFY (new_grid%j_end)
ALLOCATE( new_grid%domain_clock )
new_grid%domain_clock_created = .FALSE.
ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) ) ! initialize in setup_timekeeping
ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) )
DO i = 1, MAX_WRF_ALARMS
new_grid%alarms_created( i ) = .FALSE.
ENDDO
new_grid%time_set = .FALSE.
new_grid%is_intermediate = .FALSE.
new_grid%have_displayed_alloc_stats = .FALSE.
! set up the pointers that represent the nest hierarchy
! set this up *prior* to calling the patching or allocation
! routines so that implementations of these routines can
! traverse the nest hierarchy (through the root head_grid)
! if they need to
IF ( domain_id .NE. 1 ) THEN
new_grid%parents(1)%ptr => parent
new_grid%num_parents = 1
parent%nests(kid)%ptr => new_grid
new_grid%child_of_parent(1) = kid ! note assumption that nest can have only 1 parent
parent%num_nests = parent%num_nests + 1
END IF
new_grid%id = domain_id ! this needs to be assigned prior to calling wrf_patch_domain
CALL wrf_patch_domain( domain_id , new_domdesc , parent, parent_id, parent_domdesc , &
sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & ! z-xpose dims
sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & ! (standard)
sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
sp1x , ep1x , sm1x , em1x , & ! x-xpose dims
sp2x , ep2x , sm2x , em2x , &
sp3x , ep3x , sm3x , em3x , &
sp1y , ep1y , sm1y , em1y , & ! y-xpose dims
sp2y , ep2y , sm2y , em2y , &
sp3y , ep3y , sm3y , em3y , &
bdyzone_x , bdyzone_y , new_grid%bdy_mask &
)
new_grid%domdesc = new_domdesc
new_grid%num_nests = 0
new_grid%num_siblings = 0
new_grid%num_parents = 0
new_grid%max_tiles = 0
new_grid%num_tiles_spec = 0
new_grid%nframes = 0 ! initialize the number of frames per file (array assignment)
#if (EM_CORE == 1)
new_grid%stepping_to_time = .FALSE.
new_grid%adaptation_domain = 1
new_grid%last_step_updated = -1
#endif
CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , &
sd1, ed1, sd2, ed2, sd3, ed3, &
sm1, em1, sm2, em2, sm3, em3, &
sp1, ep1, sp2, ep2, sp3, ep3, &
sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose
sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose
)
#if MOVE_NESTS
!set these here, after alloc_space_field, which initializes vc_i, vc_j to zero
new_grid%xi = -1.0
new_grid%xj = -1.0
new_grid%vc_i = -1.0
new_grid%vc_j = -1.0
#endif
new_grid%sd31 = sd1
new_grid%ed31 = ed1
new_grid%sp31 = sp1
new_grid%ep31 = ep1
new_grid%sm31 = sm1
new_grid%em31 = em1
new_grid%sd32 = sd2
new_grid%ed32 = ed2
new_grid%sp32 = sp2
new_grid%ep32 = ep2
new_grid%sm32 = sm2
new_grid%em32 = em2
new_grid%sd33 = sd3
new_grid%ed33 = ed3
new_grid%sp33 = sp3
new_grid%ep33 = ep3
new_grid%sm33 = sm3
new_grid%em33 = em3
new_grid%sp31x = sp1x
new_grid%ep31x = ep1x
new_grid%sm31x = sm1x
new_grid%em31x = em1x
new_grid%sp32x = sp2x
new_grid%ep32x = ep2x
new_grid%sm32x = sm2x
new_grid%em32x = em2x
new_grid%sp33x = sp3x
new_grid%ep33x = ep3x
new_grid%sm33x = sm3x
new_grid%em33x = em3x
new_grid%sp31y = sp1y
new_grid%ep31y = ep1y
new_grid%sm31y = sm1y
new_grid%em31y = em1y
new_grid%sp32y = sp2y
new_grid%ep32y = ep2y
new_grid%sm32y = sm2y
new_grid%em32y = em2y
new_grid%sp33y = sp3y
new_grid%ep33y = ep3y
new_grid%sm33y = sm3y
new_grid%em33y = em3y
SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
new_grid%em21 = em1 ; new_grid%em22 = em2 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
CASE ( DATA_ORDER_YXZ )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
new_grid%em21 = em1 ; new_grid%em22 = em2 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
CASE ( DATA_ORDER_ZXY )
new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em2 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd2
new_grid%ed11 = ed2
new_grid%sp11 = sp2
new_grid%ep11 = ep2
new_grid%sm11 = sm2
new_grid%em11 = em2
CASE ( DATA_ORDER_ZYX )
new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em2 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd2
new_grid%ed11 = ed2
new_grid%sp11 = sp2
new_grid%ep11 = ep2
new_grid%sm11 = sm2
new_grid%em11 = em2
CASE ( DATA_ORDER_XZY )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em1 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
CASE ( DATA_ORDER_YZX )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em1 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
END SELECT
CALL med_add_config_info_to_grid ( new_grid ) ! this is a mediation layer routine
! Some miscellaneous state that is in the Registry but not namelist data
new_grid%tiled = .false.
new_grid%patched = .false.
NULLIFY(new_grid%mapping)
! This next set of includes causes all but the namelist_derived variables to be
! properly assigned to the new_grid record
grid => new_grid
! Allocate storage for time series metadata
ALLOCATE( grid%lattsloc( grid%max_ts_locs ) )
ALLOCATE( grid%lontsloc( grid%max_ts_locs ) )
ALLOCATE( grid%nametsloc( grid%max_ts_locs ) )
ALLOCATE( grid%desctsloc( grid%max_ts_locs ) )
ALLOCATE( grid%itsloc( grid%max_ts_locs ) )
ALLOCATE( grid%jtsloc( grid%max_ts_locs ) )
ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) )
ALLOCATE( grid%ts_filename( grid%max_ts_locs ) )
grid%ntsloc = 0
grid%ntsloc_domain = 0
#ifdef DM_PARALLEL
CALL wrf_get_dm_communicator ( grid%communicator )
CALL wrf_dm_define_comms( grid )
#endif
END SUBROUTINE alloc_and_configure_domain
SUBROUTINE get_fieldstr(ix,c,instr,outstr,noutstr,noerr)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ix
CHARACTER*(*), INTENT(IN) :: c
CHARACTER*(*), INTENT(IN) :: instr
CHARACTER*(*), INTENT(OUT) :: outstr
INTEGER, INTENT(IN) :: noutstr ! length of outstr
LOGICAL, INTENT(INOUT) :: noerr ! status
!local
#if ( WRF_PLANET == 1 )
#else
INTEGER, PARAMETER :: MAX_DEXES = 100
#endif
INTEGER I, PREV, IDEX
INTEGER DEXES(MAX_DEXES)
outstr = ""
prev = 1
dexes(1) = 1
DO i = 2,MAX_DEXES
idex = INDEX(instr(prev:LEN(TRIM(instr))),c)
IF ( idex .GT. 0 ) THEN
dexes(i) = idex+prev
prev = dexes(i)+1
ELSE
dexes(i) = LEN(TRIM(instr))+2
ENDIF
ENDDO
IF ( (dexes(ix+1)-2)-(dexes(ix)) .GT. noutstr ) THEN
noerr = .FALSE. ! would overwrite
ELSE IF( dexes(ix) .EQ. dexes(ix+1) ) THEN
noerr = .FALSE. ! not found
ELSE
outstr = instr(dexes(ix):(dexes(ix+1)-2))
noerr = noerr .AND. .TRUE.
ENDIF
END SUBROUTINE get_fieldstr
SUBROUTINE change_to_lower_case(instr,outstr)
CHARACTER*(*) ,INTENT(IN) :: instr
CHARACTER*(*) ,INTENT(OUT) :: outstr
!Local
CHARACTER*1 :: c
INTEGER ,PARAMETER :: upper_to_lower =IACHAR('a')-IACHAR('A')
INTEGER :: i,n,n1
!
outstr = ' '
N = len(instr)
N1 = len(outstr)
N = MIN(N,N1)
outstr(1:N) = instr(1:N)
DO i=1,N
c = instr(i:i)
if('A'<=c .and. c <='Z') outstr(i:i)=achar(iachar(c)+upper_to_lower)
ENDDO
RETURN
END SUBROUTINE change_to_lower_case
!
SUBROUTINE modify_io_masks1 ( grid , id )
IMPLICIT NONE
#include "streams.h"
INTEGER , INTENT(IN ) :: id
TYPE(domain), POINTER :: grid
! Local