683
684
686
687
688
689 integer, intent(in) :: ng, tile, Tindex, OutRec
690# ifdef ADJUST_BOUNDARY
691 integer, intent(in) :: LBij, UBij
692# endif
693 integer, intent(in) :: LBi, UBi, LBj, UBj
694
695
696
697 integer :: i, ifield, itrc, status
698
699 real(dp) :: my_time, scale
700
701# if defined RPCG
702 character (len=35) :: string
703# elif defined SP4DVAR
704 character (len=31) :: string
705# else
706 character (len=15) :: string
707# endif
708 character (len=*), parameter :: MyFile = &
709 & __FILE__//", tl_wrt_ini_pio"
710
711 TYPE (IO_desc_t), pointer :: ioDesc
712
713 sourcefile=myfile
714
715
716
717
718
719 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
720
721
722
723 IF (master) THEN
724# if defined RPCG
725 IF (outrec.eq.1) THEN
726 string='inner-loop initial fields '
727 ELSE IF (outrec.eq.2) THEN
728 string='final outer-loop increments '
729 ELSE IF (outrec.eq.3) THEN
730 string='sum of final outer-loop increments '
731 ELSE IF (outrec.eq.4) THEN
732 string='sum of adjoint solutions '
733 ELSE IF (outrec.eq.5) THEN
734 string='augmented correction term '
735 END IF
736# elif defined SP4DVAR
737 IF (outrec.eq.1) THEN
738 string='TLM initial fields '
739 ELSE IF ((2.le.outrec).and.(outrec.le.nsaddle+1)) THEN
740 string='TLM saddle-point starting field'
741 ELSE IF ((nsaddle+2.le.outrec).and.(outrec.le.2*nsaddle+2)) THEN
742 string='ADM saddle-point starting field'
743 END IF
744# else
745 IF (outrec.eq.1) THEN
746 string='initial fields'
747 ELSE IF (outrec.eq.2) THEN
748 string='v-increments '
749 ELSE IF (outrec.eq.3) THEN
750 string='v-increments '
751 ELSE IF (outrec.eq.4) THEN
752 string='v-summations '
753 ELSE IF (outrec.eq.5) THEN
754 string='x-increments '
755 END IF
756# endif
757# ifdef SOLVE3D
758 WRITE (stdout,10) string, outer, inner, tindex, tindex, outrec
759# else
760 WRITE (stdout,10) string, outer, inner, tindex, outrec
761# endif
762 END IF
763
764
765
766
767 my_time=tdays(ng)*day2sec
768
770 & trim(vname(1,idtime)), my_time, &
771 & (/outrec/), (/1/), &
772 & piofile = itl(ng)%pioFile, &
773 & piovar = itl(ng)%pioVar(idtime)%vd)
774 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
775
776
777
778 scale=1.0_dp
779 IF (itl(ng)%pioVar(idfsur)%dkind.eq.pio_double) THEN
781 ELSE
783 END IF
784
785 status=nf_fwrite2d(ng, itlm, itl(ng)%pioFile, idfsur, &
786 & itl(ng)%pioVar(idfsur), &
787 & outrec, iodesc, &
788 & lbi, ubi, lbj, ubj, scale, &
789# ifdef MASKING
790 & grid(ng) % rmask, &
791# endif
792# ifdef WET_DRY
793 & ocean(ng) % tl_zeta(:,:,tindex), &
794 & setfillval = .false.)
795# else
796 & ocean(ng) % tl_zeta(:,:,tindex))
797# endif
798 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
799 IF (master) THEN
800 WRITE (stdout,20) trim(vname(1,idfsur)), outrec
801 END IF
802 exit_flag=3
803 ioerror=status
804 RETURN
805 END IF
806
807# ifdef ADJUST_BOUNDARY
808
809
810
811 IF (any(lobc(:,isfsur,ng))) THEN
812 scale=1.0_dp
813 IF (itl(ng)%pioVar(idsbry(isfsur))%dkind.eq.pio_double) THEN
815 ELSE
817 END IF
818
819 status=nf_fwrite2d_bry(ng, itlm, itl(ng)%name, &
820 & itl(ng)%pioFile, &
821 & vname(1,idsbry(isfsur)), &
822 & itl(ng)%pioVar(idsbry(isfsur)), &
823 & outrec, iodesc, &
824 & lbij, ubij, nbrec(ng), scale, &
825 & boundary(ng) % tl_zeta_obc(lbij:,:,:, &
826 & tindex))
827 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
828 IF (master) THEN
829 WRITE (stdout,20) trim(vname(1,idsbry(isfsur))), outrec
830 END IF
831 exit_flag=3
832 ioerror=status
833 RETURN
834 END IF
835 END IF
836# endif
837
838
839
840 scale=1.0_dp
841 IF (itl(ng)%pioVar(idubar)%dkind.eq.pio_double) THEN
843 ELSE
845 END IF
846
847 status=nf_fwrite2d(ng, itlm, itl(ng)%pioFile, idubar, &
848 & itl(ng)%pioVar(idubar), &
849 & outrec, iodesc, &
850 & lbi, ubi, lbj, ubj, scale, &
851# ifdef MASKING
852 & grid(ng) % umask_full, &
853# endif
854 & ocean(ng) % tl_ubar(:,:,tindex))
855 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
856 IF (master) THEN
857 WRITE (stdout,20) trim(vname(1,idubar)), outrec
858 END IF
859 exit_flag=3
860 ioerror=status
861 RETURN
862 END IF
863
864# ifdef ADJUST_BOUNDARY
865
866
867
868 IF (any(lobc(:,isubar,ng))) THEN
869 scale=1.0_dp
870 IF (itl(ng)%pioVar(idsbry(isubar))%dkind.eq.pio_double) THEN
872 ELSE
874 END IF
875
876 status=nf_fwrite2d_bry(ng, itlm, itl(ng)%name, &
877 & itl(ng)%pioFile, &
878 & vname(1,idsbry(isubar)), &
879 & itl(ng)%pioVar(idsbry(isubar)), &
880 & outrec, iodesc, &
881 & lbij, ubij, nbrec(ng), scale, &
882 & boundary(ng) % tl_ubar_obc(lbij:,:,:, &
883 & tindex))
884 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
885 IF (master) THEN
886 WRITE (stdout,20) trim(vname(1,idsbry(isubar))), outrec
887 END IF
888 exit_flag=3
889 ioerror=status
890 RETURN
891 END IF
892 END IF
893# endif
894
895
896
897 scale=1.0_dp
898 IF (itl(ng)%pioVar(idvbar)%dkind.eq.pio_double) THEN
900 ELSE
902 END IF
903
904 status=nf_fwrite2d(ng, itlm, itl(ng)%pioFile, idvbar, &
905 & itl(ng)%pioVar(idvbar), &
906 & outrec, iodesc, &
907 & lbi, ubi, lbj, ubj, scale, &
908# ifdef MASKING
909 & grid(ng) % vmask_full, &
910# endif
911 & ocean(ng) % tl_vbar(:,:,tindex))
912 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
913 IF (master) THEN
914 WRITE (stdout,20) trim(vname(1,idvbar)), outrec
915 END IF
916 exit_flag=3
917 ioerror=status
918 RETURN
919 END IF
920
921# ifdef ADJUST_BOUNDARY
922
923
924
925 IF (any(lobc(:,isvbar,ng))) THEN
926 scale=1.0_dp
927 IF (itl(ng)%pioVar(idsbry(isvbar))%dkind.eq.pio_double) THEN
929 ELSE
931 END IF
932
933 status=nf_fwrite2d_bry(ng, itlm, itl(ng)%name, &
934 & itl(ng)%pioFile, &
935 & vname(1,idsbry(isvbar)), &
936 & itl(ng)%pioVar(idsbry(isvbar)), &
937 & outrec, iodesc, &
938 & lbij, ubij, nbrec(ng), scale, &
939 & boundary(ng) % tl_vbar_obc(lbij:,:,:, &
940 & tindex))
941 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
942 IF (master) THEN
943 WRITE (stdout,20) trim(vname(1,idsbry(isvbar))), outrec
944 END IF
945 exit_flag=3
946 ioerror=status
947 RETURN
948 END IF
949 END IF
950# endif
951# ifdef ADJUST_WSTRESS
952
953
954
955
956
957 scale=1.0_dp
958 IF (itl(ng)%pioVar(idusms)%dkind.eq.pio_double) THEN
960 ELSE
962 END IF
963
964 status=nf_fwrite3d(ng, itlm, itl(ng)%pioFile, idusms, &
965 & itl(ng)%pioVar(idusms), &
966 & outrec, iodesc, &
967 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
968# ifdef MASKING
969 & grid(ng) % umask, &
970# endif
971 & forces(ng) % tl_ustr(:,:,:,tindex))
972 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
973 IF (master) THEN
974 WRITE (stdout,20) trim(vname(1,idusms)), outrec
975 END IF
976 exit_flag=3
977 ioerror=status
978 RETURN
979 END IF
980
981
982
983 scale=1.0_dp
984 IF (itl(ng)%pioVar(idvsms)%dkind.eq.pio_double) THEN
986 ELSE
988 END IF
989
990 status=nf_fwrite3d(ng, itlm, itl(ng)%pioFile, idvsms, &
991 & itl(ng)%pioVar(idvsms), &
992 & outrec, iodesc, &
993 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
994# ifdef MASKING
995 & grid(ng) % vmask, &
996# endif
997 & forces(ng) % tl_vstr(:,:,:,tindex))
998 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
999 IF (master) THEN
1000 WRITE (stdout,20) trim(vname(1,idvsms)), outrec
1001 END IF
1002 exit_flag=3
1003 ioerror=status
1004 RETURN
1005 END IF
1006# endif
1007# ifdef SOLVE3D
1008
1009
1010
1011 scale=1.0_dp
1012 IF (itl(ng)%pioVar(iduvel)%dkind.eq.pio_double) THEN
1014 ELSE
1016 END IF
1017
1018 status=nf_fwrite3d(ng, itlm, itl(ng)%pioFile, iduvel, &
1019 & itl(ng)%pioVar(iduvel), &
1020 & outrec, iodesc, &
1021 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1022# ifdef MASKING
1023 & grid(ng) % umask_full, &
1024# endif
1025 & ocean(ng) % tl_u(:,:,:,tindex))
1026 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1027 IF (master) THEN
1028 WRITE (stdout,20) trim(vname(1,iduvel)), outrec
1029 END IF
1030 exit_flag=3
1031 ioerror=status
1032 RETURN
1033 END IF
1034
1035# ifdef ADJUST_BOUNDARY
1036
1037
1038
1039 IF (any(lobc(:,isuvel,ng))) THEN
1040 scale=1.0_dp
1041 IF (itl(ng)%pioVar(idsbry(isuvel))%dkind.eq.pio_double) THEN
1043 ELSE
1045 END IF
1046
1047 status=nf_fwrite3d_bry(ng, itlm, itl(ng)%name, &
1048 & itl(ng)%pioFile, &
1049 & vname(1,idsbry(isuvel)), &
1050 & itl(ng)%pioVar(idsbry(isuvel)), &
1051 & outrec, iodesc, &
1052 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
1053 & boundary(ng) % tl_u_obc(lbij:,:,:,:, &
1054 & tindex))
1055 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1056 IF (master) THEN
1057 WRITE (stdout,20) trim(vname(1,idsbry(isuvel))), outrec
1058 END IF
1059 exit_flag=3
1060 ioerror=status
1061 RETURN
1062 END IF
1063 END IF
1064# endif
1065
1066
1067
1068 scale=1.0_dp
1069 IF (itl(ng)%pioVar(idvvel)%dkind.eq.pio_double) THEN
1071 ELSE
1073 END IF
1074
1075 status=nf_fwrite3d(ng, itlm, itl(ng)%pioFile, idvvel, &
1076 & itl(ng)%pioVar(idvvel), &
1077 & outrec, iodesc, &
1078 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1079# ifdef MASKING
1080 & grid(ng) % vmask_full, &
1081# endif
1082 & ocean(ng) % tl_v(:,:,:,tindex))
1083 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1084 IF (master) THEN
1085 WRITE (stdout,20) trim(vname(1,idvvel)), outrec
1086 END IF
1087 exit_flag=3
1088 ioerror=status
1089 RETURN
1090 END IF
1091
1092# ifdef ADJUST_BOUNDARY
1093
1094
1095
1096 IF (any(lobc(:,isvvel,ng))) THEN
1097 scale=1.0_dp
1098 IF (itl(ng)%pioVar(idsbry(isvvel))%dkind.eq.pio_double) THEN
1100 ELSE
1102 END IF
1103
1104 status=nf_fwrite3d_bry(ng, itlm, itl(ng)%name, &
1105 & itl(ng)%pioFile, &
1106 & vname(1,idsbry(isvvel)), &
1107 & itl(ng)%pioVar(idsbry(isvvel)), &
1108 & outrec, iodesc, &
1109 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
1110 & boundary(ng) % tl_v_obc(lbij:,:,:,:, &
1111 & tindex))
1112 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1113 IF (master) THEN
1114 WRITE (stdout,20) trim(vname(1,idsbry(isvvel))), outrec
1115 END IF
1116 exit_flag=3
1117 ioerror=status
1118 RETURN
1119 END IF
1120 END IF
1121# endif
1122
1123
1124
1125 DO itrc=1,nt(ng)
1126 scale=1.0_dp
1127 IF (itl(ng)%pioTrc(itrc)%dkind.eq.pio_double) THEN
1129 ELSE
1131 END IF
1132
1133 status=nf_fwrite3d(ng, itlm, itl(ng)%pioFile, idtvar(itrc), &
1134 & itl(ng)%pioTrc(itrc), &
1135 & outrec, iodesc, &
1136 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1137# ifdef MASKING
1138 & grid(ng) % rmask, &
1139# endif
1140 & ocean(ng) % tl_t(:,:,:,tindex,itrc))
1141 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1142 IF (master) THEN
1143 WRITE (stdout,20) trim(vname(1,idtvar(itrc))), outrec
1144 END IF
1145 exit_flag=3
1146 ioerror=status
1147 RETURN
1148 END IF
1149 END DO
1150
1151# ifdef ADJUST_BOUNDARY
1152
1153
1154
1155 DO itrc=1,nt(ng)
1156 IF (any(lobc(:,istvar(itrc),ng))) THEN
1157 scale=1.0_dp
1158 ifield=idsbry(istvar(itrc))
1159 IF (itl(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
1161 ELSE
1163 END IF
1164
1165 status=nf_fwrite3d_bry(ng, itlm, itl(ng)%name, &
1166 & itl(ng)%pioFile, &
1167 & vname(1,ifield), &
1168 & itl(ng)%pioVar(ifield), &
1169 & outrec, iodesc, &
1170 & lbij, ubij, 1, n(ng), nbrec(ng), &
1171 & scale, &
1172 & boundary(ng) % tl_t_obc(lbij:,:,:,:, &
1173 & tindex,itrc))
1174 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1175 IF (master) THEN
1176 WRITE (stdout,20) trim(vname(1,ifield)), outrec
1177 END IF
1178 exit_flag=3
1179 ioerror=status
1180 RETURN
1181 END IF
1182 END IF
1183 END DO
1184# endif
1185# ifdef ADJUST_STFLUX
1186
1187
1188
1189
1190
1191 DO itrc=1,nt(ng)
1192 IF (lstflux(itrc,ng)) THEN
1193 scale=1.0_dp
1194 IF (itl(ng)%pioVar(idtsur(itrc))%dkind.eq.pio_double) THEN
1196 ELSE
1198 END IF
1199
1200 status=nf_fwrite3d(ng, itlm, itl(ng)%pioFile, idtsur(itrc), &
1201 & itl(ng)%pioVar(idtsur(itrc)), &
1202 & outrec, iodesc, &
1203 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
1204# ifdef MASKING
1205 & grid(ng) % rmask, &
1206# endif
1207 & forces(ng) % tl_tflux(:,:,:,tindex,itrc))
1208 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1209 IF (master) THEN
1210 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), &
1211 & outrec
1212 END IF
1213 exit_flag=3
1214 ioerror=status
1215 RETURN
1216 END IF
1217 END IF
1218 END DO
1219# endif
1220# endif
1221
1222# if defined I4DVAR || defined BACKGROUND
1223
1224
1225
1226
1227
1228
1229# if defined I4DVAR
1230
1231
1232
1233
1234 IF (lwrtcost(ng)) THEN
1236 & 'TLcost_function', &
1237 & fourdvar(ng)%ObsCost(0), &
1238 & (/nrun/), (/1/), &
1239 & piofile = dav(ng)%pioFile)
1240 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1241 END IF
1242# endif
1243
1244# ifdef BACKGROUND
1245
1246
1247
1248
1249 IF (lwrtcost(ng)) THEN
1251 & 'back_function', &
1252 & fourdvar(ng)%BackCost(0), &
1253 & (/nrun/), (/1/), &
1254 & piofile = dav(ng)%pioFile)
1255 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1256 END IF
1257# endif
1258
1259# if defined I4DVAR
1260
1261
1262
1263
1264
1265 IF (lwrtcost(ng)) THEN
1267 & 'Jmin', optimality(ng:), &
1268 & (/nrun/), (/1/), &
1269 & piofile = dav(ng)%pioFile)
1270 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1271 END IF
1272# endif
1273# endif
1274
1275
1276
1277
1278
1279
1281 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1282
1283# if defined I4DVAR || defined BACKGROUND
1285 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1286# endif
1287
1288 10 FORMAT (2x,'TL_WRT_INI_PIO - writing ',a, &
1289 & ' (Outer=',i2.2,', Inner=',i3.3,', Index=',i0, &
1290# ifdef SOLVE3D
1291 & ',',i0,', Rec=',i0,')')
1292# else
1293 & ', Rec=',i0,')')
1294# endif
1295 20 FORMAT (/,' TL_WRT_INI_PIO - error while writing variable: ',a, &
1296 & /,14x,'into tangent initial file for time record: ',i0)
1297
1298 RETURN
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_v3dobc
subroutine, public pio_netcdf_sync(ng, model, ncname, piofile)
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u3dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_r3dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u3dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r3dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_v3dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dfrc