frame/loop_based_x_shift_code.h

   1       p => grid%head_statevars%next
   2       DO WHILE ( ASSOCIATED( p ) )
   3         IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN
   4           IF ( INDEX(TRIM(p%Stagger),'X') .GT. 0 ) THEN
   5             ipf = MIN(ipe,ide)
   6           ELSE
   7             ipf = MIN(ipe,ide-1)
   8           ENDIF
   9           IF ( p%Ndim .EQ. 2 ) THEN
  10             IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(2:2) .EQ.  'Y' ) THEN
  11               IF      ( p%Type .EQ. 'r' ) THEN
  12                 IF ( SIZE(p%rfield_2d,1)*SIZE(p%rfield_2d,2) .GT. 1 ) THEN
  13                   p%rfield_2d(ips:ipf,jms:jme) = p%rfield_2d(ips+px:ipf+px,jms:jme)
  14                 ENDIF
  15               ELSE IF ( p%Type .EQ. 'd' ) THEN
  16                 IF ( SIZE(p%dfield_2d,1)*SIZE(p%dfield_2d,2) .GT. 1 ) THEN
  17                   p%dfield_2d(ips:ipf,jms:jme) = p%dfield_2d(ips+px:ipf+px,jms:jme)
  18                 ENDIF
  19               ELSE IF ( TRIM(p%Type) .EQ. 'i' ) THEN
  20                 IF ( SIZE(p%ifield_2d,1)*SIZE(p%ifield_2d,2) .GT. 1 ) THEN
  21                   p%ifield_2d(ips:ipf,jms:jme) = p%ifield_2d(ips+px:ipf+px,jms:jme)
  22                 ENDIF
  23               ELSE IF ( p%Type .EQ. 'l' ) THEN
  24                 IF ( SIZE(p%lfield_2d,1)*SIZE(p%lfield_2d,2) .GT. 1 ) THEN
  25                   p%lfield_2d(ips:ipf,jms:jme) = p%lfield_2d(ips+px:ipf+px,jms:jme)
  26                 ENDIF
  27               ENDIF
  28             ENDIF
  29           ELSE IF ( p%Ndim .EQ. 3 ) THEN
  30             IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(3:3) .EQ.  'Y' ) THEN
  31               IF      ( p%Type .EQ. 'r' ) THEN
  32                 IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,3) .GT. 1 ) THEN
  33                   p%rfield_3d(ips:ipf,:,jms:jme) = p%rfield_3d(ips+px:ipf+px,:,jms:jme)
  34                 ENDIF
  35               ELSE IF ( p%Type .EQ. 'd' ) THEN
  36                 IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,3) .GT. 1 ) THEN
  37                   p%dfield_3d(ips:ipf,:,jms:jme) = p%dfield_3d(ips+px:ipf+px,:,jms:jme)
  38                 ENDIF
  39               ELSE IF ( p%Type .EQ. 'i' ) THEN
  40                 IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,3) .GT. 1 ) THEN
  41                   p%ifield_3d(ips:ipf,:,jms:jme) = p%ifield_3d(ips+px:ipf+px,:,jms:jme)
  42                 ENDIF
  43               ELSE IF ( p%Type .EQ. 'l' ) THEN
  44                 CALL wrf_error_fatal( '3D logical arrays cannot be shifted for moving nests' )
  45               ENDIF
  46             ELSE IF (  p%MemoryOrder(1:2) .EQ. 'XY' ) THEN
  47               IF      ( p%Type .EQ. 'r' ) THEN
  48                 IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,2) .GT. 1 ) THEN
  49                   p%rfield_3d(ips:ipf,jms:jme,:) = p%rfield_3d(ips+px:ipf+px,jms:jme,:)
  50                 ENDIF
  51               ELSE IF ( p%Type .EQ. 'd' ) THEN
  52                 IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,2) .GT. 1 ) THEN
  53                   p%dfield_3d(ips:ipf,jms:jme,:) = p%dfield_3d(ips+px:ipf+px,jms:jme,:)
  54                 ENDIF
  55               ELSE IF ( p%Type .EQ. 'i' ) THEN
  56                 IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,2) .GT. 1 ) THEN
  57                   p%ifield_3d(ips:ipf,jms:jme,:) = p%ifield_3d(ips+px:ipf+px,jms:jme,:)
  58                 ENDIF
  59               ELSE IF ( p%Type .EQ. 'l' ) THEN
  60                 CALL wrf_error_fatal( '3D logical arrays cannot be shifted for moving nests' )
  61               ENDIF
  62             ENDIF
  63           ELSE IF ( p%Ndim .EQ. 4 ) THEN
  64             IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(3:3) .EQ.  'Y' ) THEN
  65               IF      ( p%Type .EQ. 'r' ) THEN
  66                 IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,3) .GT. 1 ) THEN
  67                   IF ( p%scalar_array ) THEN
  68                     DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
  69                       p%rfield_4d(ips:ipf,:,jms:jme,itrace) = p%rfield_4d(ips+px:ipf+px,:,jms:jme,itrace)
  70                     ENDDO
  71                   ELSE
  72                     p%rfield_4d(ips:ipf,:,jms:jme,:) = p%rfield_4d(ips+px:ipf+px,:,jms:jme,:)
  73                   ENDIF
  74                 ENDIF
  75               ELSE IF ( p%Type .EQ. 'd' ) THEN
  76                 IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,3) .GT. 1 ) THEN
  77                   IF ( p%scalar_array ) THEN
  78                     DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
  79                       p%dfield_4d(ips:ipf,:,jms:jme,itrace) = p%dfield_4d(ips+px:ipf+px,:,jms:jme,itrace)
  80                     ENDDO
  81                   ELSE
  82                     p%dfield_4d(ips:ipf,:,jms:jme,:) = p%dfield_4d(ips+px:ipf+px,:,jms:jme,:)
  83                   ENDIF
  84                 ENDIF
  85               ELSE IF ( p%Type .EQ. 'i' ) THEN
  86                 IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,3) .GT. 1 ) THEN
  87                   IF ( p%scalar_array ) THEN
  88                     DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
  89                       p%ifield_4d(ips:ipf,:,jms:jme,itrace) = p%ifield_4d(ips+px:ipf+px,:,jms:jme,itrace)
  90                     ENDDO
  91                   ELSE
  92                     p%ifield_4d(ips:ipf,:,jms:jme,:) = p%ifield_4d(ips+px:ipf+px,:,jms:jme,:)
  93                   ENDIF
  94                 ENDIF
  95               ELSE IF ( p%Type .EQ. 'l' ) THEN
  96                 CALL wrf_error_fatal( '4D logical arrays cannot be shifted for moving nests' )
  97               ENDIF
  98             ELSE IF (  p%MemoryOrder(1:2) .EQ. 'XY' ) THEN
  99               IF      ( p%Type .EQ. 'r' ) THEN
 100                 IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,2) .GT. 1 ) THEN
 101                   IF ( p%scalar_array ) THEN
 102                     DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
 103                       p%rfield_4d(ips:ipf,jms:jme,:,itrace) = p%rfield_4d(ips+px:ipf+px,jms:jme,:,itrace)
 104                     ENDDO
 105                   ELSE
 106                     p%rfield_4d(ips:ipf,jms:jme,:,:) = p%rfield_4d(ips+px:ipf+px,jms:jme,:,:)
 107                   ENDIF
 108                 ENDIF
 109               ELSE IF ( p%Type .EQ. 'd' ) THEN
 110                 IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,2) .GT. 1 ) THEN
 111                   IF ( p%scalar_array ) THEN
 112                     DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
 113                       p%dfield_4d(ips:ipf,jms:jme,:,itrace) = p%dfield_4d(ips+px:ipf+px,jms:jme,:,itrace)
 114                     ENDDO
 115                   ELSE
 116                     p%dfield_4d(ips:ipf,jms:jme,:,:) = p%dfield_4d(ips+px:ipf+px,jms:jme,:,:)
 117                   ENDIF
 118                 ENDIF
 119               ELSE IF ( p%Type .EQ. 'i' ) THEN
 120                 IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,2) .GT. 1 ) THEN
 121                   IF ( p%scalar_array ) THEN
 122                     DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
 123                       p%ifield_4d(ips:ipf,jms:jme,:,itrace) = p%ifield_4d(ips+px:ipf+px,jms:jme,:,itrace)
 124                     ENDDO
 125                   ELSE
 126                     p%ifield_4d(ips:ipf,jms:jme,:,:) = p%ifield_4d(ips+px:ipf+px,jms:jme,:,:)
 127                   ENDIF
 128                 ENDIF
 129               ELSE IF ( p%Type .EQ. 'l' ) THEN
 130                 CALL wrf_error_fatal( '4D logical arrays cannot be shifted for moving nests' )
 131               ENDIF
 132             ENDIF
 133           ENDIF
 134         ENDIF
 135         p => p%next
 136       ENDDO